Theory List_Misc
section‹Miscellaneous List Lemmas›
theory List_Misc
imports Main
begin
lemma list_app_singletonE:
assumes "rs⇩1 @ rs⇩2 = [x]"
obtains (first) "rs⇩1 = [x]" "rs⇩2 = []"
| (second) "rs⇩1 = []" "rs⇩2 = [x]"
using assms
by (cases "rs⇩1") auto
lemma list_app_eq_cases:
assumes "xs⇩1 @ xs⇩2 = ys⇩1 @ ys⇩2"
obtains (longer) "xs⇩1 = take (length xs⇩1) ys⇩1" "xs⇩2 = drop (length xs⇩1) ys⇩1 @ ys⇩2"
| (shorter) "ys⇩1 = take (length ys⇩1) xs⇩1" "ys⇩2 = drop (length ys⇩1) xs⇩1 @ xs⇩2"
using assms by (cases "length xs⇩1 ≤ length ys⇩1") (metis append_eq_append_conv_if)+
lemma empty_concat: "concat (map (λx. []) ms) = []" by simp
end
Theory Negation_Type
section‹Negation Type›
theory Negation_Type
imports Main
begin
text‹Store some @{typ 'a} and remember symbolically whether you mean just @{term a} or @{term "¬ a"}.›
text‹Only negated or non-negated literals›
datatype 'a negation_type = Pos 'a | Neg 'a
fun getPos :: "'a negation_type list ⇒ 'a list" where
"getPos [] = []" |
"getPos ((Pos x)#xs) = x#(getPos xs)" |
"getPos (_#xs) = getPos xs"
fun getNeg :: "'a negation_type list ⇒ 'a list" where
"getNeg [] = []" |
"getNeg ((Neg x)#xs) = x#(getNeg xs)" |
"getNeg (_#xs) = getNeg xs"
lemma getPos_append: "getPos (as@bs) = getPos as @ getPos bs"
by(induct as rule: getPos.induct) simp+
lemma getNeg_append: "getNeg (as@bs) = getNeg as @ getNeg bs"
by(induct as rule: getNeg.induct) simp+
text‹If there is @{typ "'a negation_type"}, then apply a @{term map} only to @{typ 'a}.
I.e. keep @{term Neg} and @{term Pos}›
fun NegPos_map :: "('a ⇒ 'b) ⇒ 'a negation_type list ⇒ 'b negation_type list" where
"NegPos_map _ [] = []" |
"NegPos_map f ((Pos a)#as) = (Pos (f a))#NegPos_map f as" |
"NegPos_map f ((Neg a)#as) = (Neg (f a))#NegPos_map f as"
text‹Example›
lemma "NegPos_map (λx::nat. x+1) [Pos 0, Neg 1] = [Pos 1, Neg 2]" by eval
lemma getPos_NegPos_map_simp: "(getPos (NegPos_map X (map Pos src))) = map X src"
by(induction src) (simp_all)
lemma getNeg_NegPos_map_simp: "(getNeg (NegPos_map X (map Neg src))) = map X src"
by(induction src) (simp_all)
lemma getNeg_Pos_empty: "(getNeg (NegPos_map X (map Pos src))) = []"
by(induction src) (simp_all)
lemma getNeg_Neg_empty: "(getPos (NegPos_map X (map Neg src))) = []"
by(induction src) (simp_all)
lemma getPos_NegPos_map_simp2: "(getPos (NegPos_map X src)) = map X (getPos src)"
by(induction src rule: getPos.induct) (simp_all)
lemma getNeg_NegPos_map_simp2: "(getNeg (NegPos_map X src)) = map X (getNeg src)"
by(induction src rule: getPos.induct) (simp_all)
lemma getPos_id: "getPos (map Pos xs) = xs"
by(induction xs) (simp_all)
lemma getNeg_id: "getNeg (map Neg xs) = xs"
by(induction xs) (simp_all)
lemma getPos_empty2: "(getPos (map Neg src)) = []"
by(induction src) (simp_all)
lemma getNeg_empty2: "(getNeg (map Pos src)) = []"
by(induction src) (simp_all)
lemmas NegPos_map_simps = getPos_NegPos_map_simp getNeg_NegPos_map_simp getNeg_Pos_empty getNeg_Neg_empty getPos_NegPos_map_simp2
getNeg_NegPos_map_simp2 getPos_id getNeg_id getPos_empty2 getNeg_empty2
lemma NegPos_map_map_Neg: "NegPos_map C (map Neg as) = map Neg (map C as)"
by(induction as) (simp_all)
lemma NegPos_map_map_Pos: "NegPos_map C (map Pos as) = map Pos (map C as)"
by(induction as) (simp_all)
lemma NegPos_map_append: "NegPos_map C (as @ bs) = NegPos_map C as @ NegPos_map C bs"
by(induction as rule: getNeg.induct) (simp_all)
lemma getPos_set: "Pos a ∈ set x ⟷ a ∈ set (getPos x)"
apply(induction x rule: getPos.induct)
apply(auto)
done
lemma getNeg_set: "Neg a ∈ set x ⟷ a ∈ set (getNeg x)"
apply(induction x rule: getPos.induct)
apply(auto)
done
lemma getPosgetNeg_subset: "set x ⊆ set x' ⟷ set (getPos x) ⊆ set (getPos x') ∧ set (getNeg x) ⊆ set (getNeg x')"
apply(induction x rule: getPos.induct)
apply(simp)
apply(simp add: getPos_set)
apply(rule iffI)
apply(simp_all add: getPos_set getNeg_set)
done
lemma set_Pos_getPos_subset: "Pos ` set (getPos x) ⊆ set x"
apply(induction x rule: getPos.induct)
apply(simp_all)
apply blast+
done
lemma set_Neg_getNeg_subset: "Neg ` set (getNeg x) ⊆ set x"
apply(induction x rule: getNeg.induct)
apply(simp_all)
apply blast+
done
lemmas NegPos_set = getPos_set getNeg_set getPosgetNeg_subset set_Pos_getPos_subset set_Neg_getNeg_subset
hide_fact getPos_set getNeg_set getPosgetNeg_subset set_Pos_getPos_subset set_Neg_getNeg_subset
lemma negation_type_forall_split: "(∀is∈set Ms. case is of Pos i ⇒ P i | Neg i ⇒ Q i) ⟷ (∀i∈set (getPos Ms). P i) ∧ (∀i∈set (getNeg Ms). Q i)"
apply(rule)
apply(simp split: negation_type.split_asm)
using NegPos_set(1) NegPos_set(2) apply force
apply(simp split: negation_type.split)
using NegPos_set(1) NegPos_set(2) by fastforce
fun invert :: "'a negation_type ⇒ 'a negation_type" where
"invert (Pos x) = Neg x" |
"invert (Neg x) = Pos x"
lemma invert_invert_id: "invert ∘ invert = id"
apply(clarsimp simp add: fun_eq_iff, rename_tac x, case_tac x)
by simp+
end
Theory WordInterval_Lists
theory WordInterval_Lists
imports IP_Addresses.WordInterval
Negation_Type
begin
fun l2wi_negation_type_union :: "('a::len word × 'a::len word) negation_type list ⇒ 'a::len wordinterval" where
"l2wi_negation_type_union [] = Empty_WordInterval" |
"l2wi_negation_type_union ((Pos (s,e))#ls) = wordinterval_union (WordInterval s e) (l2wi_negation_type_union ls)" |
"l2wi_negation_type_union ((Neg (s,e))#ls) = wordinterval_union (wordinterval_invert (WordInterval s e)) (l2wi_negation_type_union ls)"
lemma l2wi_negation_type_union: "wordinterval_to_set (l2wi_negation_type_union l) =
(⋃ (i,j) ∈ set (getPos l). {i .. j}) ∪ (⋃ (i,j) ∈ set (getNeg l). - {i .. j})"
apply(simp add: l2wi)
apply(induction l rule: l2wi_negation_type_union.induct)
apply(simp_all)
apply fast+
done
definition l2wi_intersect :: "('a::len word × 'a::len word) list ⇒ 'a::len wordinterval" where
"l2wi_intersect = foldl (λ acc (s,e). wordinterval_intersection (WordInterval s e) acc) wordinterval_UNIV"
lemma l2wi_intersect: "wordinterval_to_set (l2wi_intersect l) = (⋂ (i,j) ∈ set l. {i .. j})"
proof -
{ fix U
have "wordinterval_to_set (foldl (λacc (s, e). wordinterval_intersection (WordInterval s e) acc) U l) = (wordinterval_to_set U) ∩ (⋂(i, j)∈set l. {i..j})"
apply(induction l arbitrary: U)
apply(simp)
by force
} thus ?thesis
unfolding l2wi_intersect_def by simp
qed
fun l2wi_negation_type_intersect :: "('a::len word × 'a::len word) negation_type list ⇒ 'a::len wordinterval" where
"l2wi_negation_type_intersect [] = wordinterval_UNIV" |
"l2wi_negation_type_intersect ((Pos (s,e))#ls) = wordinterval_intersection (WordInterval s e) (l2wi_negation_type_intersect ls)" |
"l2wi_negation_type_intersect ((Neg (s,e))#ls) = wordinterval_intersection (wordinterval_invert (WordInterval s e)) (l2wi_negation_type_intersect ls)"
lemma l2wi_negation_type_intersect_alt: "wordinterval_to_set (l2wi_negation_type_intersect l) =
wordinterval_to_set (wordinterval_setminus (l2wi_intersect (getPos l)) (l2wi (getNeg l)))"
apply(simp add: l2wi_intersect l2wi)
apply(induction l rule :l2wi_negation_type_intersect.induct)
apply(simp_all)
apply(fast)+
done
lemma l2wi_negation_type_intersect: "wordinterval_to_set (l2wi_negation_type_intersect l) =
(⋂ (i,j) ∈ set (getPos l). {i .. j}) - (⋃ (i,j) ∈ set (getNeg l). {i .. j})"
by(simp add: l2wi_negation_type_intersect_alt l2wi_intersect l2wi)
end
Theory Repeat_Stabilize
section‹Repeat finitely Until it Stabilizes›
theory Repeat_Stabilize
imports Main
begin
text‹Repeating something a number of times›
text‹Iterating a function at most @{term n} times (first parameter) until it stabilizes.›
fun repeat_stabilize :: "nat ⇒ ('a ⇒ 'a) ⇒ 'a ⇒ 'a" where
"repeat_stabilize 0 _ v = v" |
"repeat_stabilize (Suc n) f v = (let v_new = f v in if v = v_new then v else repeat_stabilize n f v_new)"
lemma repeat_stabilize_funpow: "repeat_stabilize n f v = (f^^n) v"
proof(induction n arbitrary: v)
case (Suc n)
have "f v = v ⟹ (f^^n) v = v" by(induction n) simp_all
with Suc show ?case by(simp add: Let_def funpow_swap1)
qed(simp)
lemma repeat_stabilize_induct: "(P m) ⟹ (⋀m. P m ⟹ P (f m)) ⟹ P (repeat_stabilize n f m)"
apply(simp add: repeat_stabilize_funpow)
apply(induction n)
by(simp)+
end
Theory Firewall_Common
section‹Firewall Basic Syntax›
theory Firewall_Common
imports Main Simple_Firewall.Firewall_Common_Decision_State
"Common/Repeat_Stabilize"
begin
text‹
Our firewall model supports the following actions.
›
datatype action = Accept | Drop | Log | Reject | Call string | Return | Goto string | Empty | Unknown
text‹
We support the following algebra over primitives of type @{typ 'a}.
The type parameter @{typ 'a} denotes the primitive match condition. For example, matching
on source IP address or on protocol.
We lift the primitives to an algebra. Note that we do not have an Or expression.
›
datatype 'a match_expr = Match 'a
| MatchNot "'a match_expr"
| MatchAnd "'a match_expr" "'a match_expr"
| MatchAny
definition MatchOr :: "'a match_expr ⇒ 'a match_expr ⇒ 'a match_expr" where
"MatchOr m1 m2 = MatchNot (MatchAnd (MatchNot m1) (MatchNot m2))"
text‹A firewall rule consists of a match expression and an action.›
datatype 'a rule = Rule (get_match: "'a match_expr") (get_action: action)
lemma rules_singleton_rev_E:
"[Rule m a] = rs⇩1 @ rs⇩2 ⟹
(rs⇩1 = [Rule m a] ⟹ rs⇩2 = [] ⟹ P m a) ⟹
(rs⇩1 = [] ⟹ rs⇩2 = [Rule m a] ⟹ P m a) ⟹ P m a"
by (cases rs⇩1) auto
section‹Basic Algorithms›
text‹These algorithms should be valid for all firewall semantics.
The corresponding proofs follow once the semantics are defined.›
text‹The actions Log and Empty do not modify the packet processing in any way. They can be removed.›
fun rm_LogEmpty :: "'a rule list ⇒ 'a rule list" where
"rm_LogEmpty [] = []" |
"rm_LogEmpty ((Rule _ Empty)#rs) = rm_LogEmpty rs" |
"rm_LogEmpty ((Rule _ Log)#rs) = rm_LogEmpty rs" |
"rm_LogEmpty (r#rs) = r # rm_LogEmpty rs"
lemma rm_LogEmpty_filter: "rm_LogEmpty rs = filter (λr. get_action r ≠ Log ∧ get_action r ≠ Empty) rs"
by(induction rs rule: rm_LogEmpty.induct) (simp_all)
lemma rm_LogEmpty_seq: "rm_LogEmpty (rs1@rs2) = rm_LogEmpty rs1 @ rm_LogEmpty rs2"
by(simp add: rm_LogEmpty_filter)
text‹Optimize away MatchAny matches›
fun opt_MatchAny_match_expr_once :: "'a match_expr ⇒ 'a match_expr" where
"opt_MatchAny_match_expr_once MatchAny = MatchAny" |
"opt_MatchAny_match_expr_once (Match a) = (Match a)" |
"opt_MatchAny_match_expr_once (MatchNot (MatchNot m)) = (opt_MatchAny_match_expr_once m)" |
"opt_MatchAny_match_expr_once (MatchNot m) = MatchNot (opt_MatchAny_match_expr_once m)" |
"opt_MatchAny_match_expr_once (MatchAnd MatchAny MatchAny) = MatchAny" |
"opt_MatchAny_match_expr_once (MatchAnd MatchAny m) = (opt_MatchAny_match_expr_once m)" |
"opt_MatchAny_match_expr_once (MatchAnd m MatchAny) = (opt_MatchAny_match_expr_once m)" |
"opt_MatchAny_match_expr_once (MatchAnd _ (MatchNot MatchAny)) = (MatchNot MatchAny)" |
"opt_MatchAny_match_expr_once (MatchAnd (MatchNot MatchAny) _) = (MatchNot MatchAny)" |
"opt_MatchAny_match_expr_once (MatchAnd m1 m2) = MatchAnd (opt_MatchAny_match_expr_once m1) (opt_MatchAny_match_expr_once m2)"
text‹It is still a good idea to apply @{const opt_MatchAny_match_expr_once} multiple times. Example:›
lemma "MatchNot (opt_MatchAny_match_expr_once (MatchAnd MatchAny (MatchNot MatchAny))) = MatchNot (MatchNot MatchAny)" by simp
lemma "m = (MatchAnd (MatchAnd MatchAny MatchAny) (MatchAnd MatchAny MatchAny)) ⟹
(opt_MatchAny_match_expr_once^^2) m ≠ opt_MatchAny_match_expr_once m" by(simp add: funpow_def)
definition opt_MatchAny_match_expr :: "'a match_expr ⇒ 'a match_expr" where
"opt_MatchAny_match_expr m ≡ repeat_stabilize 2 opt_MatchAny_match_expr_once m"
text‹Rewrite @{const Reject} actions to @{const Drop} actions.
If we just care about the filtering decision (@{const FinalAllow} or @{const FinalDeny}), they should be equal.›
fun rw_Reject :: "'a rule list ⇒ 'a rule list" where
"rw_Reject [] = []" |
"rw_Reject ((Rule m Reject)#rs) = (Rule m Drop)#rw_Reject rs" |
"rw_Reject (r#rs) = r # rw_Reject rs"
text‹We call a ruleset simple iff the only actions are @{const Accept} and @{const Drop}›
definition simple_ruleset :: "'a rule list ⇒ bool" where
"simple_ruleset rs ≡ ∀r ∈ set rs. get_action r = Accept ∨ get_action r = Drop"
lemma simple_ruleset_tail: "simple_ruleset (r#rs) ⟹ simple_ruleset rs" by (simp add: simple_ruleset_def)
lemma simple_ruleset_append: "simple_ruleset (rs⇩1 @ rs⇩2) ⟷ simple_ruleset rs⇩1 ∧ simple_ruleset rs⇩2"
by(simp add: simple_ruleset_def, blast)
text‹Structural properties about match expressions›
fun has_primitive :: "'a match_expr ⇒ bool" where
"has_primitive MatchAny = False" |
"has_primitive (Match a) = True" |
"has_primitive (MatchNot m) = has_primitive m" |
"has_primitive (MatchAnd m1 m2) = (has_primitive m1 ∨ has_primitive m2)"
text‹Is a match expression equal to the @{const MatchAny} expression?
Only applicable if no primitives are in the expression.›
fun matcheq_matchAny :: "'a match_expr ⇒ bool" where
"matcheq_matchAny MatchAny ⟷ True" |
"matcheq_matchAny (MatchNot m) ⟷ ¬ (matcheq_matchAny m)" |
"matcheq_matchAny (MatchAnd m1 m2) ⟷ matcheq_matchAny m1 ∧ matcheq_matchAny m2" |
"matcheq_matchAny (Match _) = undefined"
fun matcheq_matchNone :: "'a match_expr ⇒ bool" where
"matcheq_matchNone MatchAny = False" |
"matcheq_matchNone (Match _) = False" |
"matcheq_matchNone (MatchNot MatchAny) = True" |
"matcheq_matchNone (MatchNot (Match _)) = False" |
"matcheq_matchNone (MatchNot (MatchNot m)) = matcheq_matchNone m" |
"matcheq_matchNone (MatchNot (MatchAnd m1 m2)) ⟷ matcheq_matchNone (MatchNot m1) ∧ matcheq_matchNone (MatchNot m2)" |
"matcheq_matchNone (MatchAnd m1 m2) ⟷ matcheq_matchNone m1 ∨ matcheq_matchNone m2"
lemma matachAny_matchNone: "¬ has_primitive m ⟹ matcheq_matchAny m ⟷ ¬ matcheq_matchNone m"
by(induction m rule: matcheq_matchNone.induct)(simp_all)
lemma matcheq_matchNone_no_primitive: "¬ has_primitive m ⟹ matcheq_matchNone (MatchNot m) ⟷ ¬ matcheq_matchNone m"
by(induction m rule: matcheq_matchNone.induct) (simp_all)
text‹optimizing match expressions›
fun optimize_matches_option :: "('a match_expr ⇒ 'a match_expr option) ⇒ 'a rule list ⇒ 'a rule list" where
"optimize_matches_option _ [] = []" |
"optimize_matches_option f (Rule m a#rs) = (case f m of None ⇒ optimize_matches_option f rs | Some m ⇒ (Rule m a)#optimize_matches_option f rs)"
lemma optimize_matches_option_simple_ruleset: "simple_ruleset rs ⟹ simple_ruleset (optimize_matches_option f rs)"
proof(induction rs rule:optimize_matches_option.induct)
qed(simp_all add: simple_ruleset_def split: option.split)
lemma optimize_matches_option_preserves:
"(⋀ r m. r ∈ set rs ⟹ f (get_match r) = Some m ⟹ P m) ⟹
∀ r ∈ set (optimize_matches_option f rs). P (get_match r)"
apply(induction rs rule: optimize_matches_option.induct)
apply(simp; fail)
apply(simp split: option.split)
by fastforce
lemma optimize_matches_option_append: "optimize_matches_option f (rs1@rs2) = optimize_matches_option f rs1 @ optimize_matches_option f rs2"
proof(induction rs1 rule: optimize_matches_option.induct)
qed(simp_all split: option.split)
definition optimize_matches :: "('a match_expr ⇒ 'a match_expr) ⇒ 'a rule list ⇒ 'a rule list" where
"optimize_matches f rs = optimize_matches_option (λm. (if matcheq_matchNone (f m) then None else Some (f m))) rs"
lemma optimize_matches_append: "optimize_matches f (rs1@rs2) = optimize_matches f rs1 @ optimize_matches f rs2"
by(simp add: optimize_matches_def optimize_matches_option_append)
lemma optimize_matches_fst: "optimize_matches f (r#rs) = optimize_matches f [r]@optimize_matches f rs"
by(cases r)(simp add: optimize_matches_def)
lemma optimize_matches_preserves: "(⋀ r. r ∈ set rs ⟹ P (f (get_match r))) ⟹
∀ r ∈ set (optimize_matches f rs). P (get_match r)"
unfolding optimize_matches_def
apply(rule optimize_matches_option_preserves)
by(auto split: if_split_asm)
lemma optimize_matches_simple_ruleset: "simple_ruleset rs ⟹ simple_ruleset (optimize_matches f rs)"
by(simp add: optimize_matches_def optimize_matches_option_simple_ruleset)
definition optimize_matches_a :: "(action ⇒ 'a match_expr ⇒ 'a match_expr) ⇒ 'a rule list ⇒ 'a rule list" where
"optimize_matches_a f rs = map (λr. Rule (f (get_action r) (get_match r)) (get_action r)) rs"
lemma optimize_matches_a_simple_ruleset: "simple_ruleset rs ⟹ simple_ruleset (optimize_matches_a f rs)"
by(simp add: optimize_matches_a_def simple_ruleset_def)
lemma optimize_matches_a_simple_ruleset_eq:
"simple_ruleset rs ⟹ (⋀ m a. a = Accept ∨ a = Drop ⟹ f1 a m = f2 a m) ⟹ optimize_matches_a f1 rs = optimize_matches_a f2 rs"
apply(induction rs)
apply(simp add: optimize_matches_a_def)
apply(simp add: optimize_matches_a_def)
apply(simp add: simple_ruleset_def)
done
lemma optimize_matches_a_preserves: "(⋀ r. r ∈ set rs ⟹ P (f (get_action r) (get_match r)))
⟹ ∀ r ∈ set (optimize_matches_a f rs). P (get_match r)"
by(induction rs)(simp_all add: optimize_matches_a_def)
end
Theory Semantics
theory Semantics
imports Main Firewall_Common "Common/List_Misc" "HOL-Library.LaTeXsugar"
begin
section‹Big Step Semantics›
text‹
The assumption we apply in general is that the firewall does not alter any packets.
›
text‹A firewall ruleset is a map of chain names
(e.g., INPUT, OUTPUT, FORWARD, arbitrary-user-defined-chain) to a list of rules.
The list of rules is processed sequentially.›
type_synonym 'a ruleset = "string ⇀ 'a rule list"
text‹A matcher (parameterized by the type of primitive @{typ 'a} and packet @{typ 'p})
is a function which just tells whether a given primitive and packet matches.›
type_synonym ('a, 'p) matcher = "'a ⇒ 'p ⇒ bool"
text‹Example: Assume a network packet only has a destination street number
(for simplicity, of type @{typ "nat"}) and we only support the following match expression:
Is the packet's street number within a certain range?
The type for the primitive could then be @{typ "nat × nat"} and a possible implementation
for @{typ "(nat × nat, nat) matcher"} could be
@{term "match_street_number (a,b) p ⟷ p ∈ {a .. b}"}.
Usually, the primitives are a datatype which supports interfaces, IP addresses, protocols,
ports, payload, ...›
text‹Given an @{typ "('a, 'p) matcher"} and a match expression, does a packet of type @{typ 'p}
match the match expression?›
fun matches :: "('a, 'p) matcher ⇒ 'a match_expr ⇒ 'p ⇒ bool" where
"matches γ (MatchAnd e1 e2) p ⟷ matches γ e1 p ∧ matches γ e2 p" |
"matches γ (MatchNot me) p ⟷ ¬ matches γ me p" |
"matches γ (Match e) p ⟷ γ e p" |
"matches _ MatchAny _ ⟷ True"
inductive iptables_bigstep :: "'a ruleset ⇒ ('a, 'p) matcher ⇒ 'p ⇒ 'a rule list ⇒ state ⇒ state ⇒ bool"
("_,_,_⊢ ⟨_, _⟩ ⇒ _" [60,60,60,20,98,98] 89)
for Γ and γ and p where
skip: "Γ,γ,p⊢ ⟨[], t⟩ ⇒ t" |
accept: "matches γ m p ⟹ Γ,γ,p⊢ ⟨[Rule m Accept], Undecided⟩ ⇒ Decision FinalAllow" |
drop: "matches γ m p ⟹ Γ,γ,p⊢ ⟨[Rule m Drop], Undecided⟩ ⇒ Decision FinalDeny" |
reject: "matches γ m p ⟹ Γ,γ,p⊢ ⟨[Rule m Reject], Undecided⟩ ⇒ Decision FinalDeny" |
log: "matches γ m p ⟹ Γ,γ,p⊢ ⟨[Rule m Log], Undecided⟩ ⇒ Undecided" |
empty: "matches γ m p ⟹ Γ,γ,p⊢ ⟨[Rule m Empty], Undecided⟩ ⇒ Undecided" |
nomatch: "¬ matches γ m p ⟹ Γ,γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ Undecided" |
decision: "Γ,γ,p⊢ ⟨rs, Decision X⟩ ⇒ Decision X" |
seq: "⟦Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ t; Γ,γ,p⊢ ⟨rs⇩2, t⟩ ⇒ t'⟧ ⟹ Γ,γ,p⊢ ⟨rs⇩1@rs⇩2, Undecided⟩ ⇒ t'" |
call_return: "⟦ matches γ m p; Γ chain = Some (rs⇩1@[Rule m' Return]@rs⇩2);
matches γ m' p; Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided ⟧ ⟹
Γ,γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Undecided" |
call_result: "⟦ matches γ m p; Γ chain = Some rs; Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ t ⟧ ⟹
Γ,γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ t"
text‹
The semantic rules again in pretty format:
\begin{center}
@{thm[mode=Axiom] skip [no_vars]}\\[1ex]
@{thm[mode=Rule] accept [no_vars]}\\[1ex]
@{thm[mode=Rule] drop [no_vars]}\\[1ex]
@{thm[mode=Rule] reject [no_vars]}\\[1ex]
@{thm[mode=Rule] log [no_vars]}\\[1ex]
@{thm[mode=Rule] empty [no_vars]}\\[1ex]
@{thm[mode=Rule] nomatch [no_vars]}\\[1ex]
@{thm[mode=Rule] decision [no_vars]}\\[1ex]
@{thm[mode=Rule] seq [no_vars]} \\[1ex]
@{thm[mode=Rule] call_return [no_vars]}\\[1ex]
@{thm[mode=Rule] call_result [no_vars]}
\end{center}
›
lemma deny:
"matches γ m p ⟹ a = Drop ∨ a = Reject ⟹ iptables_bigstep Γ γ p [Rule m a] Undecided (Decision FinalDeny)"
by (auto intro: drop reject)
lemma seq_cons:
assumes "Γ,γ,p⊢ ⟨[r],Undecided⟩ ⇒ t" and "Γ,γ,p⊢ ⟨rs,t⟩ ⇒ t'"
shows "Γ,γ,p⊢ ⟨r#rs, Undecided⟩ ⇒ t'"
proof -
from assms have "Γ,γ,p⊢ ⟨[r] @ rs, Undecided⟩ ⇒ t'" by (rule seq)
thus ?thesis by simp
qed
lemma iptables_bigstep_induct
[case_names Skip Allow Deny Log Nomatch Decision Seq Call_return Call_result,
induct pred: iptables_bigstep]:
"⟦ Γ,γ,p⊢ ⟨rs,s⟩ ⇒ t;
⋀t. P [] t t;
⋀m a. matches γ m p ⟹ a = Accept ⟹ P [Rule m a] Undecided (Decision FinalAllow);
⋀m a. matches γ m p ⟹ a = Drop ∨ a = Reject ⟹ P [Rule m a] Undecided (Decision FinalDeny);
⋀m a. matches γ m p ⟹ a = Log ∨ a = Empty ⟹ P [Rule m a] Undecided Undecided;
⋀m a. ¬ matches γ m p ⟹ P [Rule m a] Undecided Undecided;
⋀rs X. P rs (Decision X) (Decision X);
⋀rs rs⇩1 rs⇩2 t t'. rs = rs⇩1 @ rs⇩2 ⟹ Γ,γ,p⊢ ⟨rs⇩1,Undecided⟩ ⇒ t ⟹ P rs⇩1 Undecided t ⟹ Γ,γ,p⊢ ⟨rs⇩2,t⟩ ⇒ t' ⟹ P rs⇩2 t t' ⟹ P rs Undecided t';
⋀m a chain rs⇩1 m' rs⇩2. matches γ m p ⟹ a = Call chain ⟹ Γ chain = Some (rs⇩1 @ [Rule m' Return] @ rs⇩2) ⟹ matches γ m' p ⟹ Γ,γ,p⊢ ⟨rs⇩1,Undecided⟩ ⇒ Undecided ⟹ P rs⇩1 Undecided Undecided ⟹ P [Rule m a] Undecided Undecided;
⋀m a chain rs t. matches γ m p ⟹ a = Call chain ⟹ Γ chain = Some rs ⟹ Γ,γ,p⊢ ⟨rs,Undecided⟩ ⇒ t ⟹ P rs Undecided t ⟹ P [Rule m a] Undecided t ⟧ ⟹
P rs s t"
by (induction rule: iptables_bigstep.induct) auto
lemma skipD: "Γ,γ,p⊢ ⟨r, s⟩ ⇒ t ⟹ r = [] ⟹ s = t"
by (induction rule: iptables_bigstep.induct) auto
lemma decisionD: "Γ,γ,p⊢ ⟨r, s⟩ ⇒ t ⟹ s = Decision X ⟹ t = Decision X"
by (induction rule: iptables_bigstep_induct) auto
context
notes skipD[dest] list_app_singletonE[elim]
begin
lemma acceptD: "Γ,γ,p⊢ ⟨r, s⟩ ⇒ t ⟹ r = [Rule m Accept] ⟹ matches γ m p ⟹ s = Undecided ⟹ t = Decision FinalAllow"
by (induction rule: iptables_bigstep.induct) auto
lemma dropD: "Γ,γ,p⊢ ⟨r, s⟩ ⇒ t ⟹ r = [Rule m Drop] ⟹ matches γ m p ⟹ s = Undecided ⟹ t = Decision FinalDeny"
by (induction rule: iptables_bigstep.induct) auto
lemma rejectD: "Γ,γ,p⊢ ⟨r, s⟩ ⇒ t ⟹ r = [Rule m Reject] ⟹ matches γ m p ⟹ s = Undecided ⟹ t = Decision FinalDeny"
by (induction rule: iptables_bigstep.induct) auto
lemma logD: "Γ,γ,p⊢ ⟨r, s⟩ ⇒ t ⟹ r = [Rule m Log] ⟹ matches γ m p ⟹ s = Undecided ⟹ t = Undecided"
by (induction rule: iptables_bigstep.induct) auto
lemma emptyD: "Γ,γ,p⊢ ⟨r, s⟩ ⇒ t ⟹ r = [Rule m Empty] ⟹ matches γ m p ⟹ s = Undecided ⟹ t = Undecided"
by (induction rule: iptables_bigstep.induct) auto
lemma nomatchD: "Γ,γ,p⊢ ⟨r, s⟩ ⇒ t ⟹ r = [Rule m a] ⟹ s = Undecided ⟹ ¬ matches γ m p ⟹ t = Undecided"
by (induction rule: iptables_bigstep.induct) auto
lemma callD:
assumes "Γ,γ,p⊢ ⟨r, s⟩ ⇒ t" "r = [Rule m (Call chain)]" "s = Undecided" "matches γ m p" "Γ chain = Some rs"
obtains "Γ,γ,p⊢ ⟨rs,s⟩ ⇒ t"
| rs⇩1 rs⇩2 m' where "rs = rs⇩1 @ Rule m' Return # rs⇩2" "matches γ m' p" "Γ,γ,p⊢ ⟨rs⇩1,s⟩ ⇒ Undecided" "t = Undecided"
using assms
proof (induction r s t arbitrary: rs rule: iptables_bigstep.induct)
case (seq rs⇩1)
thus ?case by (cases rs⇩1) auto
qed auto
end
lemmas iptables_bigstepD = skipD acceptD dropD rejectD logD emptyD nomatchD decisionD callD
lemma seq':
assumes "rs = rs⇩1 @ rs⇩2" "Γ,γ,p⊢ ⟨rs⇩1,s⟩ ⇒ t" "Γ,γ,p⊢ ⟨rs⇩2,t⟩ ⇒ t'"
shows "Γ,γ,p⊢ ⟨rs,s⟩ ⇒ t'"
using assms by (cases s) (auto intro: seq decision dest: decisionD)
lemma seq'_cons: "Γ,γ,p⊢ ⟨[r],s⟩ ⇒ t ⟹ Γ,γ,p⊢ ⟨rs,t⟩ ⇒ t' ⟹ Γ,γ,p⊢ ⟨r#rs, s⟩ ⇒ t'"
by (metis decision decisionD state.exhaust seq_cons)
lemma seq_split:
assumes "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t" "rs = rs⇩1@rs⇩2"
obtains t' where "Γ,γ,p⊢ ⟨rs⇩1,s⟩ ⇒ t'" "Γ,γ,p⊢ ⟨rs⇩2,t'⟩ ⇒ t"
using assms
proof (induction rs s t arbitrary: rs⇩1 rs⇩2 thesis rule: iptables_bigstep_induct)
case Allow thus ?case by (cases rs⇩1) (auto intro: iptables_bigstep.intros)
next
case Deny thus ?case by (cases rs⇩1) (auto intro: iptables_bigstep.intros)
next
case Log thus ?case by (cases rs⇩1) (auto intro: iptables_bigstep.intros)
next
case Nomatch thus ?case by (cases rs⇩1) (auto intro: iptables_bigstep.intros)
next
case (Seq rs rsa rsb t t')
hence rs: "rsa @ rsb = rs⇩1 @ rs⇩2" by simp
note List.append_eq_append_conv_if[simp]
from rs show ?case
proof (cases rule: list_app_eq_cases)
case longer
with Seq have t1: "Γ,γ,p⊢ ⟨take (length rsa) rs⇩1, Undecided⟩ ⇒ t"
by simp
from Seq longer obtain t2
where t2a: "Γ,γ,p⊢ ⟨drop (length rsa) rs⇩1,t⟩ ⇒ t2"
and rs2_t2: "Γ,γ,p⊢ ⟨rs⇩2,t2⟩ ⇒ t'"
by blast
with t1 rs2_t2 have "Γ,γ,p⊢ ⟨take (length rsa) rs⇩1 @ drop (length rsa) rs⇩1,Undecided⟩ ⇒ t2"
by (blast intro: iptables_bigstep.seq)
with Seq rs2_t2 show ?thesis
by simp
next
case shorter
with rs have rsa': "rsa = rs⇩1 @ take (length rsa - length rs⇩1) rs⇩2"
by (metis append_eq_conv_conj length_drop)
from shorter rs have rsb': "rsb = drop (length rsa - length rs⇩1) rs⇩2"
by (metis append_eq_conv_conj length_drop)
from Seq rsa' obtain t1
where t1a: "Γ,γ,p⊢ ⟨rs⇩1,Undecided⟩ ⇒ t1"
and t1b: "Γ,γ,p⊢ ⟨take (length rsa - length rs⇩1) rs⇩2,t1⟩ ⇒ t"
by blast
from rsb' Seq.hyps have t2: "Γ,γ,p⊢ ⟨drop (length rsa - length rs⇩1) rs⇩2,t⟩ ⇒ t'"
by blast
with seq' t1b have "Γ,γ,p⊢ ⟨rs⇩2,t1⟩ ⇒ t'"
by fastforce
with Seq t1a show ?thesis
by fast
qed
next
case Call_return
hence "Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided" "Γ,γ,p⊢ ⟨rs⇩2, Undecided⟩ ⇒ Undecided"
by (case_tac [!] rs⇩1) (auto intro: iptables_bigstep.skip iptables_bigstep.call_return)
thus ?case by fact
next
case (Call_result _ _ _ _ t)
show ?case
proof (cases rs⇩1)
case Nil
with Call_result have "Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided" "Γ,γ,p⊢ ⟨rs⇩2, Undecided⟩ ⇒ t"
by (auto intro: iptables_bigstep.intros)
thus ?thesis by fact
next
case Cons
with Call_result have "Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ t" "Γ,γ,p⊢ ⟨rs⇩2, t⟩ ⇒ t"
by (auto intro: iptables_bigstep.intros)
thus ?thesis by fact
qed
qed (auto intro: iptables_bigstep.intros)
lemma seqE:
assumes "Γ,γ,p⊢ ⟨rs⇩1@rs⇩2, s⟩ ⇒ t"
obtains ti where "Γ,γ,p⊢ ⟨rs⇩1,s⟩ ⇒ ti" "Γ,γ,p⊢ ⟨rs⇩2,ti⟩ ⇒ t"
using assms by (force elim: seq_split)
lemma seqE_cons:
assumes "Γ,γ,p⊢ ⟨r#rs, s⟩ ⇒ t"
obtains ti where "Γ,γ,p⊢ ⟨[r],s⟩ ⇒ ti" "Γ,γ,p⊢ ⟨rs,ti⟩ ⇒ t"
using assms by (metis append_Cons append_Nil seqE)
lemma nomatch':
assumes "⋀r. r ∈ set rs ⟹ ¬ matches γ (get_match r) p"
shows "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ s"
proof(cases s)
case Undecided
have "∀r∈set rs. ¬ matches γ (get_match r) p ⟹ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided"
proof(induction rs)
case Nil
thus ?case by (fast intro: skip)
next
case (Cons r rs)
hence "Γ,γ,p⊢ ⟨[r], Undecided⟩ ⇒ Undecided"
by (cases r) (auto intro: nomatch)
with Cons show ?case
by (fastforce intro: seq_cons)
qed
with assms Undecided show ?thesis by simp
qed (blast intro: decision)
text‹there are only two cases when there can be a Return on top-level:
▪ the firewall is in a Decision state
▪ the return does not match
In both cases, it is not applied!
›
lemma no_free_return: assumes "Γ,γ,p⊢ ⟨[Rule m Return], Undecided⟩ ⇒ t" and "matches γ m p" shows "False"
proof -
{ fix a s
have no_free_return_hlp: "Γ,γ,p⊢ ⟨a,s⟩ ⇒ t ⟹ matches γ m p ⟹ s = Undecided ⟹ a = [Rule m Return] ⟹ False"
proof (induction rule: iptables_bigstep.induct)
case (seq rs⇩1)
thus ?case
by (cases rs⇩1) (auto dest: skipD)
qed simp_all
} with assms show ?thesis by blast
qed
lemma seq_progress: "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t ⟹ rs = rs⇩1@rs⇩2 ⟹ Γ,γ,p⊢ ⟨rs⇩1, s⟩ ⇒ t' ⟹ Γ,γ,p⊢ ⟨rs⇩2, t'⟩ ⇒ t"
proof(induction arbitrary: rs⇩1 rs⇩2 t' rule: iptables_bigstep_induct)
case Allow
thus ?case
by (cases "rs⇩1") (auto intro: iptables_bigstep.intros dest: iptables_bigstepD)
next
case Deny
thus ?case
by (cases "rs⇩1") (auto intro: iptables_bigstep.intros dest: iptables_bigstepD)
next
case Log
thus ?case
by (cases "rs⇩1") (auto intro: iptables_bigstep.intros dest: iptables_bigstepD)
next
case Nomatch
thus ?case
by (cases "rs⇩1") (auto intro: iptables_bigstep.intros dest: iptables_bigstepD)
next
case Decision
thus ?case
by (cases "rs⇩1") (auto intro: iptables_bigstep.intros dest: iptables_bigstepD)
next
case(Seq rs rsa rsb t t' rs⇩1 rs⇩2 t'')
hence rs: "rsa @ rsb = rs⇩1 @ rs⇩2" by simp
note List.append_eq_append_conv_if[simp]
from rs show "Γ,γ,p⊢ ⟨rs⇩2,t''⟩ ⇒ t'"
proof(cases rule: list_app_eq_cases)
case longer
have "rs⇩1 = take (length rsa) rs⇩1 @ drop (length rsa) rs⇩1"
by auto
with Seq longer show ?thesis
by (metis append_Nil2 skipD seq_split)
next
case shorter
with Seq(7) Seq.hyps(3) Seq.IH(1) rs show ?thesis
by (metis seq' append_eq_conv_conj)
qed
next
case(Call_return m a chain rsa m' rsb)
have xx: "Γ,γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ t' ⟹ matches γ m p ⟹
Γ chain = Some (rsa @ Rule m' Return # rsb) ⟹
matches γ m' p ⟹
Γ,γ,p⊢ ⟨rsa, Undecided⟩ ⇒ Undecided ⟹
t' = Undecided"
apply(erule callD)
apply(simp_all)
apply(erule seqE)
apply(erule seqE_cons)
by (metis Call_return.IH no_free_return self_append_conv skipD)
show ?case
proof (cases rs⇩1)
case (Cons r rs)
thus ?thesis
using Call_return
apply(case_tac "[Rule m a] = rs⇩2")
apply(simp)
apply(simp)
using xx by blast
next
case Nil
moreover hence "t' = Undecided"
by (metis Call_return.hyps(1) Call_return.prems(2) append.simps(1) decision no_free_return seq state.exhaust)
moreover have "⋀m. Γ,γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ Undecided"
by (metis (no_types) Call_return(2) Call_return.hyps(3) Call_return.hyps(4) Call_return.hyps(5) call_return nomatch)
ultimately show ?thesis
using Call_return.prems(1) by auto
qed
next
case(Call_result m a chain rs t)
thus ?case
proof (cases rs⇩1)
case Cons
thus ?thesis
using Call_result
apply(auto simp add: iptables_bigstep.skip iptables_bigstep.call_result dest: skipD)
apply(drule callD, simp_all)
apply blast
by (metis Cons_eq_appendI append_self_conv2 no_free_return seq_split)
qed (fastforce intro: iptables_bigstep.intros dest: skipD)
qed (auto dest: iptables_bigstepD)
theorem iptables_bigstep_deterministic: assumes "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t" and "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t'" shows "t = t'"
proof -
{ fix r1 r2 m t
assume a1: "Γ,γ,p⊢ ⟨r1 @ Rule m Return # r2, Undecided⟩ ⇒ t" and a2: "matches γ m p" and a3: "Γ,γ,p⊢ ⟨r1,Undecided⟩ ⇒ Undecided"
have False
proof -
from a1 a3 have "Γ,γ,p⊢ ⟨Rule m Return # r2, Undecided⟩ ⇒ t"
by (blast intro: seq_progress)
hence "Γ,γ,p⊢ ⟨[Rule m Return] @ r2, Undecided⟩ ⇒ t"
by simp
from seqE[OF this] obtain ti where "Γ,γ,p⊢ ⟨[Rule m Return], Undecided⟩ ⇒ ti" by blast
with no_free_return a2 show False by fast
qed
} note no_free_return_seq=this
from assms show ?thesis
proof (induction arbitrary: t' rule: iptables_bigstep_induct)
case Seq
thus ?case
by (metis seq_progress)
next
case Call_result
thus ?case
by (metis no_free_return_seq callD)
next
case Call_return
thus ?case
by (metis append_Cons callD no_free_return_seq)
qed (auto dest: iptables_bigstepD)
qed
lemma iptables_bigstep_to_undecided: "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ Undecided ⟹ s = Undecided"
by (metis decisionD state.exhaust)
lemma iptables_bigstep_to_decision: "Γ,γ,p⊢ ⟨rs, Decision Y⟩ ⇒ Decision X ⟹ Y = X"
by (metis decisionD state.inject)
lemma Rule_UndecidedE:
assumes "Γ,γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ Undecided"
obtains (nomatch) "¬ matches γ m p"
| (log) "a = Log ∨ a = Empty"
| (call) c where "a = Call c" "matches γ m p"
using assms
proof (induction "[Rule m a]" Undecided Undecided rule: iptables_bigstep_induct)
case Seq
thus ?case
by (metis append_eq_Cons_conv append_is_Nil_conv iptables_bigstep_to_undecided)
qed simp_all
lemma Rule_DecisionE:
assumes "Γ,γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ Decision X"
obtains (call) chain where "matches γ m p" "a = Call chain"
| (accept_reject) "matches γ m p" "X = FinalAllow ⟹ a = Accept" "X = FinalDeny ⟹ a = Drop ∨ a = Reject"
using assms
proof (induction "[Rule m a]" Undecided "Decision X" rule: iptables_bigstep_induct)
case (Seq rs⇩1)
thus ?case
by (cases rs⇩1) (auto dest: skipD)
qed simp_all
lemma log_remove:
assumes "Γ,γ,p⊢ ⟨rs⇩1 @ [Rule m Log] @ rs⇩2, s⟩ ⇒ t"
shows "Γ,γ,p⊢ ⟨rs⇩1 @ rs⇩2, s⟩ ⇒ t"
proof -
from assms obtain t' where t': "Γ,γ,p⊢ ⟨rs⇩1, s⟩ ⇒ t'" "Γ,γ,p⊢ ⟨[Rule m Log] @ rs⇩2, t'⟩ ⇒ t"
by (blast elim: seqE)
hence "Γ,γ,p⊢ ⟨Rule m Log # rs⇩2, t'⟩ ⇒ t"
by simp
then obtain t'' where "Γ,γ,p⊢ ⟨[Rule m Log], t'⟩ ⇒ t''" "Γ,γ,p⊢ ⟨rs⇩2, t''⟩ ⇒ t"
by (blast elim: seqE_cons)
with t' show ?thesis
by (metis state.exhaust iptables_bigstep_deterministic decision log nomatch seq)
qed
lemma empty_empty:
assumes "Γ,γ,p⊢ ⟨rs⇩1 @ [Rule m Empty] @ rs⇩2, s⟩ ⇒ t"
shows "Γ,γ,p⊢ ⟨rs⇩1 @ rs⇩2, s⟩ ⇒ t"
proof -
from assms obtain t' where t': "Γ,γ,p⊢ ⟨rs⇩1, s⟩ ⇒ t'" "Γ,γ,p⊢ ⟨[Rule m Empty] @ rs⇩2, t'⟩ ⇒ t"
by (blast elim: seqE)
hence "Γ,γ,p⊢ ⟨Rule m Empty # rs⇩2, t'⟩ ⇒ t"
by simp
then obtain t'' where "Γ,γ,p⊢ ⟨[Rule m Empty], t'⟩ ⇒ t''" "Γ,γ,p⊢ ⟨rs⇩2, t''⟩ ⇒ t"
by (blast elim: seqE_cons)
with t' show ?thesis
by (metis state.exhaust iptables_bigstep_deterministic decision empty nomatch seq)
qed
lemma Unknown_actions_False: "Γ,γ,p⊢ ⟨r # rs, Undecided⟩ ⇒ t ⟹ r = Rule m a ⟹ matches γ m p ⟹ a = Unknown ∨ (∃chain. a = Goto chain) ⟹ False"
proof -
have 1: "Γ,γ,p⊢ ⟨[Rule m Unknown], Undecided⟩ ⇒ t ⟹ matches γ m p ⟹ False"
by (induction "[Rule m Unknown]" Undecided t rule: iptables_bigstep.induct)
(auto elim: list_app_singletonE dest: skipD)
{ fix chain
have "Γ,γ,p⊢ ⟨[Rule m (Goto chain)], Undecided⟩ ⇒ t ⟹ matches γ m p ⟹ False"
by (induction "[Rule m (Goto chain)]" Undecided t rule: iptables_bigstep.induct)
(auto elim: list_app_singletonE dest: skipD)
}note 2=this
show "Γ,γ,p⊢ ⟨r # rs, Undecided⟩ ⇒ t ⟹ r = Rule m a ⟹ matches γ m p ⟹ a = Unknown ∨ (∃chain. a = Goto chain) ⟹ False"
apply(erule seqE_cons)
apply(case_tac ti)
apply(simp_all)
using Rule_UndecidedE apply fastforce
by (metis "1" "2" decision iptables_bigstep_deterministic)
qed
text‹
The notation we prefer in the paper. The semantics are defined for fixed ‹Γ› and ‹γ›
›
locale iptables_bigstep_fixedbackground =
fixes Γ::"'a ruleset"
and γ::"('a, 'p) matcher"
begin
inductive iptables_bigstep' :: "'p ⇒ 'a rule list ⇒ state ⇒ state ⇒ bool"
("_⊢'' ⟨_, _⟩ ⇒ _" [60,20,98,98] 89)
for p where
skip: "p⊢' ⟨[], t⟩ ⇒ t" |
accept: "matches γ m p ⟹ p⊢' ⟨[Rule m Accept], Undecided⟩ ⇒ Decision FinalAllow" |
drop: "matches γ m p ⟹ p⊢' ⟨[Rule m Drop], Undecided⟩ ⇒ Decision FinalDeny" |
reject: "matches γ m p ⟹ p⊢' ⟨[Rule m Reject], Undecided⟩ ⇒ Decision FinalDeny" |
log: "matches γ m p ⟹ p⊢' ⟨[Rule m Log], Undecided⟩ ⇒ Undecided" |
empty: "matches γ m p ⟹ p⊢' ⟨[Rule m Empty], Undecided⟩ ⇒ Undecided" |
nomatch: "¬ matches γ m p ⟹ p⊢' ⟨[Rule m a], Undecided⟩ ⇒ Undecided" |
decision: "p⊢' ⟨rs, Decision X⟩ ⇒ Decision X" |
seq: "⟦p⊢' ⟨rs⇩1, Undecided⟩ ⇒ t; p⊢' ⟨rs⇩2, t⟩ ⇒ t'⟧ ⟹ p⊢' ⟨rs⇩1@rs⇩2, Undecided⟩ ⇒ t'" |
call_return: "⟦ matches γ m p; Γ chain = Some (rs⇩1@[Rule m' Return]@rs⇩2);
matches γ m' p; p⊢' ⟨rs⇩1, Undecided⟩ ⇒ Undecided ⟧ ⟹
p⊢' ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Undecided" |
call_result: "⟦ matches γ m p; p⊢' ⟨the (Γ chain), Undecided⟩ ⇒ t ⟧ ⟹
p⊢' ⟨[Rule m (Call chain)], Undecided⟩ ⇒ t"
definition wf_Γ:: "'a rule list ⇒ bool" where
"wf_Γ rs ≡ ∀rsg ∈ ran Γ ∪ {rs}. (∀r ∈ set rsg. ∀ chain. get_action r = Call chain ⟶ Γ chain ≠ None)"
lemma wf_Γ_append: "wf_Γ (rs1@rs2) ⟷ wf_Γ rs1 ∧ wf_Γ rs2"
by(simp add: wf_Γ_def, blast)
lemma wf_Γ_tail: "wf_Γ (r # rs) ⟹ wf_Γ rs" by(simp add: wf_Γ_def)
lemma wf_Γ_Call: "wf_Γ [Rule m (Call chain)] ⟹ wf_Γ (the (Γ chain)) ∧ (∃rs. Γ chain = Some rs)"
apply(simp add: wf_Γ_def)
by (metis option.collapse ranI)
lemma "wf_Γ rs ⟹ p⊢' ⟨rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
apply(rule iffI)
apply(rotate_tac 1)
apply(induction rs s t rule: iptables_bigstep'.induct)
apply(auto intro: iptables_bigstep.intros simp: wf_Γ_append dest!: wf_Γ_Call)[11]
apply(rotate_tac 1)
apply(induction rs s t rule: iptables_bigstep.induct)
apply(auto intro: iptables_bigstep'.intros simp: wf_Γ_append dest!: wf_Γ_Call)[11]
done
end
text‹Showing that semantics are defined.
For rulesets which can be loaded by the Linux kernel. The kernel does not allow loops.›
text‹
We call a ruleset well-formed (wf) iff all @{const Call}s are into actually existing chains.
›
definition wf_chain :: "'a ruleset ⇒ 'a rule list ⇒ bool" where
"wf_chain Γ rs ≡ (∀r ∈ set rs. ∀ chain. get_action r = Call chain ⟶ Γ chain ≠ None)"
lemma wf_chain_append: "wf_chain Γ (rs1@rs2) ⟷ wf_chain Γ rs1 ∧ wf_chain Γ rs2"
by(simp add: wf_chain_def, blast)
lemma wf_chain_fst: "wf_chain Γ (r # rs) ⟹ wf_chain Γ (rs)"
by(simp add: wf_chain_def)
text‹This is what our tool will check at runtime›
definition sanity_wf_ruleset :: "(string × 'a rule list) list ⇒ bool" where
"sanity_wf_ruleset Γ ≡ distinct (map fst Γ) ∧
(∀ rs ∈ ran (map_of Γ). (∀r ∈ set rs. case get_action r of Accept ⇒ True
| Drop ⇒ True
| Reject ⇒ True
| Log ⇒ True
| Empty ⇒ True
| Call chain ⇒ chain ∈ dom (map_of Γ)
| Goto chain ⇒ chain ∈ dom (map_of Γ)
| Return ⇒ True
| _ ⇒ False))"
lemma sanity_wf_ruleset_wf_chain: "sanity_wf_ruleset Γ ⟹ rs ∈ ran (map_of Γ) ⟹ wf_chain (map_of Γ) rs"
apply(simp add: sanity_wf_ruleset_def wf_chain_def)
by fastforce
lemma sanity_wf_ruleset_start: "sanity_wf_ruleset Γ ⟹ chain_name ∈ dom (map_of Γ) ⟹
default_action = Accept ∨ default_action = Drop ⟹
wf_chain (map_of Γ) [Rule MatchAny (Call chain_name), Rule MatchAny default_action]"
apply(simp add: sanity_wf_ruleset_def wf_chain_def)
apply(safe)
apply(simp_all)
apply blast+
done
lemma [code]: "sanity_wf_ruleset Γ =
(let dom = map fst Γ;
ran = map snd Γ
in distinct dom ∧
(∀ rs ∈ set ran. (∀r ∈ set rs. case get_action r of Accept ⇒ True
| Drop ⇒ True
| Reject ⇒ True
| Log ⇒ True
| Empty ⇒ True
| Call chain ⇒ chain ∈ set dom
| Goto chain ⇒ chain ∈ set dom
| Return ⇒ True
| _ ⇒ False)))"
proof -
have set_map_fst: "set (map fst Γ) = dom (map_of Γ)"
by (simp add: dom_map_of_conv_image_fst)
have set_map_snd: "distinct (map fst Γ) ⟹ set (map snd Γ) = ran (map_of Γ)"
by (simp add: ran_distinct)
show ?thesis
unfolding sanity_wf_ruleset_def Let_def
apply(subst set_map_fst)+
apply(rule iffI)
apply(elim conjE)
apply(subst set_map_snd)
apply(simp)
apply(simp)
apply(elim conjE)
apply(subst(asm) set_map_snd)
apply(simp_all)
done
qed
lemma semantics_bigstep_defined1: assumes "∀rsg ∈ ran Γ ∪ {rs}. wf_chain Γ rsg"
and "∀rsg ∈ ran Γ ∪ {rs}. ∀ r ∈ set rsg. (∀chain. get_action r ≠ Goto chain) ∧ get_action r ≠ Unknown"
and "∀ r ∈ set rs. get_action r ≠ Return"
and "(∀name ∈ dom Γ. ∃t. Γ,γ,p⊢ ⟨the (Γ name), Undecided⟩ ⇒ t)"
shows "∃t. Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
using assms proof(induction rs)
case Nil thus ?case
apply(rule_tac x=s in exI)
by(simp add: skip)
next
case (Cons r rs)
from Cons.prems Cons.IH obtain t' where t': "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t'"
apply simp
apply(elim conjE)
apply(simp add: wf_chain_fst)
by blast
obtain m a where r: "r = Rule m a" by(cases r) blast
show ?case
proof(cases "matches γ m p")
case False
hence "Γ,γ,p⊢ ⟨[r], s⟩ ⇒ s"
apply(cases s)
apply(simp add: nomatch r)
by(simp add: decision)
thus ?thesis
apply(rule_tac x=t' in exI)
apply(rule_tac t=s in seq'_cons)
apply assumption
using t' by(simp)
next
case True
show ?thesis
proof(cases s)
case (Decision X) thus ?thesis
apply(rule_tac x="Decision X" in exI)
by(simp add: decision)
next
case Undecided
have "∃t. Γ,γ,p⊢ ⟨Rule m a # rs, Undecided⟩ ⇒ t"
proof(cases a)
case Accept with True show ?thesis
apply(rule_tac x="Decision FinalAllow" in exI)
apply(rule_tac t="Decision FinalAllow" in seq'_cons)
by(auto intro: iptables_bigstep.intros)
next
case Drop with True show ?thesis
apply(rule_tac x="Decision FinalDeny" in exI)
apply(rule_tac t="Decision FinalDeny" in seq'_cons)
by(auto intro: iptables_bigstep.intros)
next
case Log with True t' Undecided show ?thesis
apply(rule_tac x=t' in exI)
apply(rule_tac t=Undecided in seq'_cons)
by(auto intro: iptables_bigstep.intros)
next
case Reject with True show ?thesis
apply(rule_tac x="Decision FinalDeny" in exI)
apply(rule_tac t="Decision FinalDeny" in seq'_cons)
by(auto intro: iptables_bigstep.intros)[2]
next
case Return with Cons.prems(3)[simplified r] show ?thesis by simp
next
case Goto with Cons.prems(2)[simplified r] show ?thesis by auto
next
case (Call chain_name)
from Call Cons.prems(1) obtain rs' where 1: "Γ chain_name = Some rs'" by(simp add: r wf_chain_def) blast
with Cons.prems(4) obtain t'' where 2: "Γ,γ,p⊢ ⟨the (Γ chain_name), Undecided⟩ ⇒ t''" by blast
from 1 2 True have "Γ,γ,p⊢ ⟨[Rule m (Call chain_name)], Undecided⟩ ⇒ t''" by(auto dest: call_result)
with Call t' Undecided show ?thesis
apply(simp add: r)
apply(cases t'')
apply simp
apply(rule_tac x=t' in exI)
apply(rule_tac t=Undecided in seq'_cons)
apply(auto intro: iptables_bigstep.intros)[2]
apply(simp)
apply(rule_tac x=t'' in exI)
apply(rule_tac t=t'' in seq'_cons)
apply(auto intro: iptables_bigstep.intros)
done
next
case Empty with True t' Undecided show ?thesis
apply(rule_tac x=t' in exI)
apply(rule_tac t=Undecided in seq'_cons)
by(auto intro: iptables_bigstep.intros)
next
case Unknown with Cons.prems(2)[simplified r] show ?thesis by(simp)
qed
thus ?thesis
unfolding r Undecided by simp
qed
qed
qed
text‹Showing the main theorem›
context
begin
private lemma iptables_bigstep_defined_if_singleton_rules:
"∀ r ∈ set rs. (∃t. Γ,γ,p⊢ ⟨[r], s⟩ ⇒ t) ⟹ ∃t. Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
proof(induction rs arbitrary: s)
case Nil hence "Γ,γ,p⊢ ⟨[], s⟩ ⇒ s" by(simp add: skip)
thus ?case by blast
next
case(Cons r rs s)
from Cons.prems obtain t where t: "Γ,γ,p⊢ ⟨[r], s⟩ ⇒ t" by simp blast
with Cons show ?case
proof(cases t)
case Decision with t show ?thesis by (meson decision seq'_cons)
next
case Undecided
from Cons obtain t' where t': "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t'" by simp blast
with Undecided t show ?thesis
apply(rule_tac x=t' in exI)
apply(rule seq'_cons)
apply(simp)
using iptables_bigstep_to_undecided by fastforce
qed
qed
text‹well founded relation.›
definition calls_chain :: "'a ruleset ⇒ (string × string) set" where
"calls_chain Γ = {(r, s). case Γ r of Some rs ⇒ ∃m. Rule m (Call s) ∈ set rs | None ⇒ False}"
lemma calls_chain_def2: "calls_chain Γ = {(caller, callee). ∃rs m. Γ caller = Some rs ∧ Rule m (Call callee) ∈ set rs}"
unfolding calls_chain_def
apply(safe)
apply(simp split: option.split_asm)
apply(simp)
by blast
text‹example›
private lemma "calls_chain [
''FORWARD'' ↦ [(Rule m1 Log), (Rule m2 (Call ''foo'')), (Rule m3 Accept), (Rule m' (Call ''baz''))],
''foo'' ↦ [(Rule m4 Log), (Rule m5 Return), (Rule m6 (Call ''bar''))],
''bar'' ↦ [],
''baz'' ↦ []] =
{(''FORWARD'', ''foo''), (''FORWARD'', ''baz''), (''foo'', ''bar'')}"
unfolding calls_chain_def by(auto split: option.split_asm if_split_asm)
private lemma "wf (calls_chain [
''FORWARD'' ↦ [(Rule m1 Log), (Rule m2 (Call ''foo'')), (Rule m3 Accept), (Rule m' (Call ''baz''))],
''foo'' ↦ [(Rule m4 Log), (Rule m5 Return), (Rule m6 (Call ''bar''))],
''bar'' ↦ [],
''baz'' ↦ []])"
proof -
have g: "calls_chain [''FORWARD'' ↦ [(Rule m1 Log), (Rule m2 (Call ''foo'')), (Rule m3 Accept), (Rule m' (Call ''baz''))],
''foo'' ↦ [(Rule m4 Log), (Rule m5 Return), (Rule m6 (Call ''bar''))],
''bar'' ↦ [],
''baz'' ↦ []] = {(''FORWARD'', ''foo''), (''FORWARD'', ''baz''), (''foo'', ''bar'')}"
by(auto simp add: calls_chain_def split: option.split_asm if_split_asm)
show ?thesis
unfolding g
apply(simp)
apply safe
apply(erule rtranclE, simp_all)
apply(erule rtranclE, simp_all)
done
qed
text‹In our proof, we will need the reverse.›
private definition called_by_chain :: "'a ruleset ⇒ (string × string) set" where
"called_by_chain Γ = {(callee, caller). case Γ caller of Some rs ⇒ ∃m. Rule m (Call callee) ∈ set rs | None ⇒ False}"
private lemma called_by_chain_converse: "calls_chain Γ = converse (called_by_chain Γ)"
apply(simp add: calls_chain_def called_by_chain_def)
by blast
private lemma wf_called_by_chain: "finite (calls_chain Γ) ⟹ wf (calls_chain Γ) ⟹ wf (called_by_chain Γ)"
apply(frule Wellfounded.wf_acyclic)
apply(drule(1) Wellfounded.finite_acyclic_wf_converse)
apply(simp add: called_by_chain_converse)
done
private lemma helper_cases_call_subchain_defined_or_return:
"(∀x∈ran Γ. wf_chain Γ x) ⟹
∀rsg∈ran Γ. ∀r∈set rsg. (∀chain. get_action r ≠ Goto chain) ∧ get_action r ≠ Unknown ⟹
∀y m. ∀r∈set rs_called. r = Rule m (Call y) ⟶ (∃t. Γ,γ,p⊢ ⟨[Rule m (Call y)], Undecided⟩ ⇒ t) ⟹
wf_chain Γ rs_called ⟹
∀r∈set rs_called. (∀chain. get_action r ≠ Goto chain) ∧ get_action r ≠ Unknown ⟹
(∃t. Γ,γ,p⊢ ⟨rs_called, Undecided⟩ ⇒ t) ∨
(∃rs_called1 rs_called2 m'.
rs_called = (rs_called1 @ [Rule m' Return] @ rs_called2) ∧
matches γ m' p ∧ Γ,γ,p⊢ ⟨rs_called1, Undecided⟩ ⇒ Undecided)"
proof(induction rs_called arbitrary:)
case Nil hence "∃t. Γ,γ,p⊢ ⟨[], Undecided⟩ ⇒ t"
apply(rule_tac x=Undecided in exI)
by(simp add: skip)
thus ?case by simp
next
case (Cons r rs)
from Cons.prems have "wf_chain Γ [r]" by(simp add: wf_chain_def)
from Cons.prems have IH:"(∃t'. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ t') ∨
(∃rs_called1 rs_called2 m'.
rs = (rs_called1 @ [Rule m' Return] @ rs_called2) ∧
matches γ m' p ∧ Γ,γ,p⊢ ⟨rs_called1, Undecided⟩ ⇒ Undecided)"
apply -
apply(rule Cons.IH)
apply(auto dest: wf_chain_fst)
done
from Cons.prems have case_call: "r = Rule m (Call y) ⟹ (∃t. Γ,γ,p⊢ ⟨[Rule m (Call y)], Undecided⟩ ⇒ t)" for y m
by(simp)
obtain m a where r: "r = Rule m a" by(cases r) simp
from Cons.prems have a_not: "(∀chain. a ≠ Goto chain) ∧ a ≠ Unknown" by(simp add: r)
have ex_neq_ret: "a ≠ Return ⟹ ∃t. Γ,γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ t"
proof(cases "matches γ m p")
case False thus ?thesis by(rule_tac x=Undecided in exI)(simp add: nomatch; fail)
next
case True
assume "a ≠ Return"
show ?thesis
proof(cases a)
case Accept with True show ?thesis
by(rule_tac x="Decision FinalAllow" in exI) (simp add: accept; fail)
next
case Drop with True show ?thesis
by(rule_tac x="Decision FinalDeny" in exI) (simp add: drop; fail)
next
case Log with True show ?thesis
by(rule_tac x="Undecided" in exI)(simp add: log; fail)
next
case Reject with True show ?thesis
by(rule_tac x="Decision FinalDeny" in exI) (simp add: reject; fail)
next
case Call with True show ?thesis
apply(simp)
apply(rule case_call)
apply(simp add: r; fail)
done
next
case Empty with True show ?thesis by(rule_tac x="Undecided" in exI) (simp add: empty; fail)
next
case Return with ‹a ≠ Return› show ?thesis by simp
qed(simp_all add: a_not)
qed
have *: "?case"
if pre: "rs = rs_called1 @ Rule m' Return # rs_called2 ∧ matches γ m' p ∧ Γ,γ,p⊢ ⟨rs_called1, Undecided⟩ ⇒ Undecided"
for rs_called1 m' rs_called2
proof(cases "matches γ m p")
case False thus ?thesis
apply -
apply(rule disjI2)
apply(rule_tac x="r#rs_called1" in exI)
apply(rule_tac x=rs_called2 in exI)
apply(rule_tac x=m' in exI)
apply(simp add: r pre)
apply(rule_tac t=Undecided in seq_cons)
apply(simp add: r nomatch; fail)
apply(simp add: pre; fail)
done
next
case True
from pre have rule_case_dijs1: "∃X. Γ,γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ Decision X ⟹ ?thesis"
apply -
apply(rule disjI1)
apply(elim exE conjE, rename_tac X)
apply(simp)
apply(rule_tac x="Decision X" in exI)
apply(rule_tac t="Decision X" in seq_cons)
apply(simp add: r; fail)
apply(simp add: decision; fail)
done
from pre have rule_case_dijs2: "Γ,γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ Undecided ⟹ ?thesis"
apply -
apply(rule disjI2)
apply(rule_tac x="r#rs_called1" in exI)
apply(rule_tac x=rs_called2 in exI)
apply(rule_tac x=m' in exI)
apply(simp add: r)
apply(rule_tac t=Undecided in seq_cons)
apply(simp; fail)
apply(simp;fail)
done
show ?thesis
proof(cases a)
case Accept show ?thesis
apply(rule rule_case_dijs1)
apply(rule_tac x="FinalAllow" in exI)
using True pre Accept by(simp add: accept)
next
case Drop show ?thesis
apply(rule rule_case_dijs1)
apply(rule_tac x="FinalDeny" in exI)
using True Drop by(simp add: deny)
next
case Log show ?thesis
apply(rule rule_case_dijs2)
using Log True by(simp add: log)
next
case Reject show ?thesis
apply(rule rule_case_dijs1)
apply(rule_tac x="FinalDeny" in exI)
using Reject True by(simp add: reject)
next
case (Call x5)
have "∃t. Γ,γ,p⊢ ⟨[Rule m (Call x5)], Undecided⟩ ⇒ t" by(rule case_call) (simp add: r Call)
with Call pre True show ?thesis
apply(simp)
apply(elim exE, rename_tac t_called)
apply(case_tac t_called)
apply(simp)
apply(rule disjI2)
apply(rule_tac x="r#rs_called1" in exI)
apply(rule_tac x=rs_called2 in exI)
apply(rule_tac x=m' in exI)
apply(simp add: r)
apply(rule_tac t=Undecided in seq_cons)
apply(simp add: r; fail)
apply(simp; fail)
apply(rule disjI1)
apply(rule_tac x=t_called in exI)
apply(rule_tac t=t_called in seq_cons)
apply(simp add: r; fail)
apply(simp add: decision; fail)
done
next
case Empty show ?thesis
apply(rule rule_case_dijs2)
using Empty True by(simp add: pre empty)
next
case Return show ?thesis
apply(rule disjI2)
apply(rule_tac x="[]" in exI)
apply(rule_tac x="rs_called1 @ Rule m' Return # rs_called2" in exI)
apply(rule_tac x=m in exI)
using Return True pre by(simp add: skip r)
qed(simp_all add: a_not)
qed
from IH have **: "a ≠ Return ⟶ (∃t. Γ,γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ t) ⟹ ?case"
proof(elim disjE, goal_cases)
case 2
from this obtain rs_called1 m' rs_called2 where
a1: "rs = rs_called1 @ [Rule m' Return] @ rs_called2" and
a2: "matches γ m' p" and a3: "Γ,γ,p⊢ ⟨rs_called1, Undecided⟩ ⇒ Undecided" by blast
show ?case
apply(rule *)
using a1 a2 a3 by simp
next
case 1 thus ?case
proof(cases "a ≠ Return")
case True
with 1 obtain t1 t2 where t1: "Γ,γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ t1"
and t2: "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ t2" by blast
from t1 t2 show ?thesis
apply -
apply(rule disjI1)
apply(simp add: r)
apply(cases t1)
apply(simp_all)
apply(rule_tac x=t2 in exI)
apply(rule_tac seq'_cons)
apply(simp_all)
apply (meson decision seq_cons)
done
next
case False show ?thesis
proof(cases "matches γ m p")
assume "¬ matches γ m p" with 1 show ?thesis
apply -
apply(rule disjI1)
apply(elim exE)
apply(rename_tac t')
apply(rule_tac x=t' in exI)
apply(rule_tac t=Undecided in seq_cons)
apply(simp add: r nomatch; fail)
by(simp)
next
assume "matches γ m p" with False show ?thesis
apply -
apply(rule disjI2)
apply(rule_tac x="[]" in exI)
apply(rule_tac x=rs in exI)
apply(rule_tac x=m in exI)
apply(simp add: r skip; fail)
done
qed
qed
qed
thus ?case using ex_neq_ret by blast
qed
lemma helper_defined_single:
assumes "wf (called_by_chain Γ)"
and "∀rsg ∈ ran Γ ∪ {[Rule m a]}. wf_chain Γ rsg"
and "∀rsg ∈ ran Γ ∪ {[Rule m a]}. ∀ r ∈ set rsg. (¬(∃chain. get_action r = Goto chain)) ∧ get_action r ≠ Unknown"
and "a ≠ Return"
shows "∃t. Γ,γ,p⊢ ⟨[Rule m a], s⟩ ⇒ t"
proof(cases s)
case (Decision decision) thus ?thesis
apply(rule_tac x="Decision decision" in exI)
apply(simp)
using iptables_bigstep.decision by fast
next
case Undecided
have "∃t. Γ,γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ t"
proof(cases "matches γ m p")
case False with assms show ?thesis
apply(rule_tac x=Undecided in exI)
apply(rule_tac t=Undecided in seq'_cons)
apply (metis empty_iff empty_set insert_iff list.simps(15) nomatch' rule.sel(1))
apply(simp add: skip; fail)
done
next
case True
show ?thesis
proof(cases a)
case Unknown with assms(3) show ?thesis by simp
next
case Goto with assms(3) show ?thesis by auto
next
case Accept with True show ?thesis by(auto intro: iptables_bigstep.intros)
next
case Drop with True show ?thesis by(auto intro: iptables_bigstep.intros)
next
case Reject with True show ?thesis by(auto intro: iptables_bigstep.intros)
next
case Log with True show ?thesis by(auto intro: iptables_bigstep.intros)
next
case Empty with True show ?thesis by(auto intro: iptables_bigstep.intros)
next
case Return with assms show ?thesis by simp
next
case (Call chain_name)
thm wf_induct_rule[where r="(calls_chain Γ)" and P="λx. ∃t. Γ,γ,p⊢ ⟨[Rule m (Call x)], Undecided⟩ ⇒ t"]
from assms have "wf (called_by_chain Γ)"
"∀rsg∈ran Γ. wf_chain Γ rsg"
"∀rsg∈ran Γ. ∀r∈set rsg. (∀chain. get_action r ≠ Goto chain) ∧ get_action r ≠ Unknown" by auto
hence "matches γ m p ⟹ wf_chain Γ [Rule m (Call chain_name)] ⟹ (∃t. Γ,γ,p⊢ ⟨[Rule m (Call chain_name)], Undecided⟩ ⇒ t)"
proof(induction arbitrary: m rule: wf_induct_rule[where r="called_by_chain Γ"])
case (less chain_name_neu)
from less.prems have "Γ chain_name_neu ≠ None" by(simp add: wf_chain_def)
from this obtain rs_called where rs_called: "Γ chain_name_neu = Some rs_called" by blast
from less rs_called have "wf_chain Γ rs_called" by (simp add: ranI)
from less rs_called have "rs_called ∈ ran Γ" by (simp add: ranI)
from less.prems rs_called have
"∀y m. ∀r ∈ set rs_called. r = Rule m (Call y) ⟶ (y, chain_name_neu) ∈ called_by_chain Γ ∧ wf_chain Γ [Rule m (Call y)]"
apply(simp)
apply(intro impI allI conjI)
apply(simp add: called_by_chain_def)
apply blast
apply(simp add: wf_chain_def)
apply (meson ranI rule.sel(2))
done
with less have "∀y m. ∀r∈set rs_called. r = Rule m (Call y) ⟶ (∃t. Γ,γ,p⊢ ⟨[Rule m (Call y)], Undecided⟩ ⇒ t)"
apply(intro allI, rename_tac y my)
apply(case_tac "matches γ my p")
apply blast
apply(intro ballI impI)
apply(rule_tac x=Undecided in exI)
apply(simp add: nomatch; fail)
done
from less.prems(4) rs_called ‹rs_called ∈ ran Γ›
helper_cases_call_subchain_defined_or_return[OF less.prems(3) less.prems(4) this ‹wf_chain Γ rs_called›] have
"(∃t. Γ,γ,p⊢ ⟨rs_called, Undecided⟩ ⇒ t) ∨
(∃rs_called1 rs_called2 m'.
Γ chain_name_neu = Some (rs_called1@[Rule m' Return]@rs_called2) ∧
matches γ m' p ∧ Γ,γ,p⊢ ⟨rs_called1, Undecided⟩ ⇒ Undecided)" by simp
thus ?case
proof(elim disjE exE conjE)
fix t
assume a: "Γ,γ,p⊢ ⟨rs_called, Undecided⟩ ⇒ t" show ?case
using call_result[OF less.prems(1) rs_called a] by(blast)
next
fix m' rs_called1 rs_called2
assume a1: "Γ chain_name_neu = Some (rs_called1 @ [Rule m' Return] @ rs_called2)"
and a2: "matches γ m' p" and a3: "Γ,γ,p⊢ ⟨rs_called1, Undecided⟩ ⇒ Undecided"
show ?case using call_return[OF less.prems(1) a1 a2 a3 ] by(blast)
qed
qed
with True assms Call show ?thesis by simp
qed
qed
with Undecided show ?thesis by simp
qed
private lemma helper_defined_ruleset_calledby: "wf (called_by_chain Γ) ⟹
∀rsg ∈ ran Γ ∪ {rs}. wf_chain Γ rsg ⟹
∀rsg ∈ ran Γ ∪ {rs}. ∀ r ∈ set rsg. (¬(∃chain. get_action r = Goto chain)) ∧ get_action r ≠ Unknown ⟹
∀ r ∈ set rs. get_action r ≠ Return ⟹
∃t. Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
apply(rule iptables_bigstep_defined_if_singleton_rules)
apply(intro ballI, rename_tac r, case_tac r, rename_tac m a, simp)
apply(rule helper_defined_single)
apply(simp; fail)
apply(simp add: wf_chain_def; fail)
apply fastforce
apply fastforce
done
corollary semantics_bigstep_defined: "finite (calls_chain Γ) ⟹ wf (calls_chain Γ) ⟹
∀rsg ∈ ran Γ ∪ {rs}. wf_chain Γ rsg ⟹
∀rsg ∈ ran Γ ∪ {rs}. ∀ r ∈ set rsg. (∀x. get_action r ≠ Goto x) ∧ get_action r ≠ Unknown ⟹
∀ r ∈ set rs. get_action r ≠ Return ⟹
∃t. Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
apply(drule(1) wf_called_by_chain)
apply(thin_tac "wf (calls_chain Γ)")
apply(rule helper_defined_ruleset_calledby)
apply(simp_all)
done
end
text‹Common Algorithms›
lemma iptables_bigstep_rm_LogEmpty: "Γ,γ,p⊢ ⟨rm_LogEmpty rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
proof(induction rs arbitrary: s)
case Nil thus ?case by(simp)
next
case (Cons r rs)
have step_IH: "(⋀s. Γ,γ,p⊢ ⟨rs1, s⟩ ⇒ t = Γ,γ,p⊢ ⟨rs2, s⟩ ⇒ t) ⟹
Γ,γ,p⊢ ⟨r#rs1, s⟩ ⇒ t = Γ,γ,p⊢ ⟨r#rs2, s⟩ ⇒ t" for rs1 rs2 r
by (meson seq'_cons seqE_cons)
have case_log: "Γ,γ,p⊢ ⟨Rule m Log # rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t" for m
apply(rule iffI)
apply(erule seqE_cons)
apply (metis append_Nil log_remove seq')
apply(rule_tac t=s in seq'_cons)
apply(cases s)
apply(cases "matches γ m p")
apply(simp add: log; fail)
apply(simp add: nomatch; fail)
apply(simp add: decision; fail)
apply simp
done
have case_empty: "Γ,γ,p⊢ ⟨Rule m Empty # rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t" for m
apply(rule iffI)
apply(erule seqE_cons)
apply (metis append_Nil empty_empty seq')
apply(rule_tac t=s in seq'_cons)
apply(cases s)
apply(cases "matches γ m p")
apply(simp add: empty; fail)
apply(simp add: nomatch; fail)
apply(simp add: decision; fail)
apply simp
done
from Cons show ?case
apply(cases r, rename_tac m a)
apply(case_tac a)
apply(simp_all)
apply(simp_all cong: step_IH)
apply(simp_all add: case_log case_empty)
done
qed
lemma iptables_bigstep_rw_Reject: "Γ,γ,p⊢ ⟨rw_Reject rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
proof(induction rs arbitrary: s)
case Nil thus ?case by(simp)
next
case (Cons r rs)
have step_IH: "(⋀s. Γ,γ,p⊢ ⟨rs1, s⟩ ⇒ t = Γ,γ,p⊢ ⟨rs2, s⟩ ⇒ t) ⟹
Γ,γ,p⊢ ⟨r#rs1, s⟩ ⇒ t = Γ,γ,p⊢ ⟨r#rs2, s⟩ ⇒ t" for rs1 rs2 r
by (meson seq'_cons seqE_cons)
have fst_rule: "(⋀t. Γ,γ,p⊢ ⟨[r1], s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨[r2], s⟩ ⇒ t) ⟹
Γ,γ,p⊢ ⟨r1 # rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨r2 # rs, s⟩ ⇒ t" for r1 r2 rs s t
by (meson seq'_cons seqE_cons)
have dropreject: "Γ,γ,p⊢ ⟨[Rule m Drop], s⟩ ⇒ t = Γ,γ,p⊢ ⟨[Rule m Reject], s⟩ ⇒ t" for m t
apply(cases s)
apply(cases "matches γ m p")
using drop reject dropD rejectD apply fast
using nomatch nomatchD apply fast
using decision decisionD apply fast
done
from Cons show ?case
apply(cases r, rename_tac m a)
apply simp
apply(case_tac a)
apply(simp_all)
apply(simp_all cong: step_IH)
apply(rule fst_rule)
apply(simp add: dropreject)
done
qed
end
Theory Matching
theory Matching
imports Semantics
begin
subsection‹Boolean Matcher Algebra›
lemma MatchOr: "matches γ (MatchOr m1 m2) p ⟷ matches γ m1 p ∨ matches γ m2 p"
by(simp add: MatchOr_def)
lemma opt_MatchAny_match_expr_correct: "matches γ (opt_MatchAny_match_expr m) = matches γ m"
proof -
have "matches γ (opt_MatchAny_match_expr_once m) = matches γ m" for m
apply(simp add: fun_eq_iff)
by(induction m rule: opt_MatchAny_match_expr_once.induct) (simp_all)
thus ?thesis
apply(simp add: opt_MatchAny_match_expr_def)
apply(rule repeat_stabilize_induct)
by(simp)+
qed
lemma matcheq_matchAny: "¬ has_primitive m ⟹ matcheq_matchAny m ⟷ matches γ m p"
by(induction m) simp_all
lemma matcheq_matchNone: "¬ has_primitive m ⟹ matcheq_matchNone m ⟷ ¬ matches γ m p"
by(auto dest: matcheq_matchAny matachAny_matchNone)
lemma matcheq_matchNone_not_matches: "matcheq_matchNone m ⟹ ¬ matches γ m p"
by(induction m rule: matcheq_matchNone.induct) auto
text‹Lemmas about matching in the @{const iptables_bigstep} semantics.›
lemma matches_rule_iptables_bigstep:
assumes "matches γ m p ⟷ matches γ m' p"
shows "Γ,γ,p⊢ ⟨[Rule m a], s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨[Rule m' a], s⟩ ⇒ t" (is "?l ⟷?r")
proof -
{
fix m m'
assume "Γ,γ,p⊢ ⟨[Rule m a], s⟩ ⇒ t" "matches γ m p ⟷ matches γ m' p"
hence "Γ,γ,p⊢ ⟨[Rule m' a], s⟩ ⇒ t"
by (induction "[Rule m a]" s t rule: iptables_bigstep_induct)
(auto intro: iptables_bigstep.intros simp: Cons_eq_append_conv dest: skipD)
}
with assms show ?thesis by blast
qed
lemma matches_rule_and_simp_help:
assumes "matches γ m p"
shows "Γ,γ,p⊢ ⟨[Rule (MatchAnd m m') a'], Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨[Rule m' a'], Undecided⟩ ⇒ t" (is "?l ⟷?r")
proof
assume ?l thus ?r
by (induction "[Rule (MatchAnd m m') a']" Undecided t rule: iptables_bigstep_induct)
(auto intro: iptables_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
next
assume ?r thus ?l
by (induction "[Rule m' a']" Undecided t rule: iptables_bigstep_induct)
(auto intro: iptables_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
qed
lemma matches_MatchNot_simp:
assumes "matches γ m p"
shows "Γ,γ,p⊢ ⟨[Rule (MatchNot m) a], Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨[], Undecided⟩ ⇒ t" (is "?l ⟷ ?r")
proof
assume ?l thus ?r
by (induction "[Rule (MatchNot m) a]" "Undecided" t rule: iptables_bigstep_induct)
(auto intro: iptables_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
next
assume ?r
hence "t = Undecided"
by (metis skipD)
with assms show ?l
by (fastforce intro: nomatch)
qed
lemma matches_MatchNotAnd_simp:
assumes "matches γ m p"
shows "Γ,γ,p⊢ ⟨[Rule (MatchAnd (MatchNot m) m') a], Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨[], Undecided⟩ ⇒ t" (is "?l ⟷ ?r")
proof
assume ?l thus ?r
by (induction "[Rule (MatchAnd (MatchNot m) m') a]" "Undecided" t rule: iptables_bigstep_induct)
(auto intro: iptables_bigstep.intros simp add: assms Cons_eq_append_conv dest: skipD)
next
assume ?r
hence "t = Undecided"
by (metis skipD)
with assms show ?l
by (fastforce intro: nomatch)
qed
lemma matches_rule_and_simp:
assumes "matches γ m p"
shows "Γ,γ,p⊢ ⟨[Rule (MatchAnd m m') a'], s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨[Rule m' a'], s⟩ ⇒ t"
proof (cases s)
case Undecided
with assms show ?thesis
by (simp add: matches_rule_and_simp_help)
next
case Decision
thus ?thesis by (metis decision decisionD)
qed
lemma iptables_bigstep_MatchAnd_comm:
"Γ,γ,p⊢ ⟨[Rule (MatchAnd m1 m2) a], s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨[Rule (MatchAnd m2 m1) a], s⟩ ⇒ t"
proof -
{ fix m1 m2
have "Γ,γ,p⊢ ⟨[Rule (MatchAnd m1 m2) a], s⟩ ⇒ t ⟹ Γ,γ,p⊢ ⟨[Rule (MatchAnd m2 m1) a], s⟩ ⇒ t"
proof (induction "[Rule (MatchAnd m1 m2) a]" s t rule: iptables_bigstep_induct)
case Seq thus ?case
by (metis Nil_is_append_conv append_Nil butlast_append butlast_snoc seq)
qed (auto intro: iptables_bigstep.intros)
}
thus ?thesis by blast
qed
subsection‹Add match›
definition add_match :: "'a match_expr ⇒ 'a rule list ⇒ 'a rule list" where
"add_match m rs = map (λr. case r of Rule m' a' ⇒ Rule (MatchAnd m m') a') rs"
lemma add_match_split: "add_match m (rs1@rs2) = add_match m rs1 @ add_match m rs2"
unfolding add_match_def
by (fact map_append)
lemma add_match_split_fst: "add_match m (Rule m' a' # rs) = Rule (MatchAnd m m') a' # add_match m rs"
unfolding add_match_def
by simp
lemma add_match_distrib:
"Γ,γ,p⊢ ⟨add_match m1 (add_match m2 rs), s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨add_match m2 (add_match m1 rs), s⟩ ⇒ t"
proof -
{
fix m1 m2
have "Γ,γ,p⊢ ⟨add_match m1 (add_match m2 rs), s⟩ ⇒ t ⟹ Γ,γ,p⊢ ⟨add_match m2 (add_match m1 rs), s⟩ ⇒ t"
proof (induction rs arbitrary: s)
case Nil thus ?case by (simp add: add_match_def)
next
case (Cons r rs)
from Cons obtain m a where r: "r = Rule m a" by (cases r) simp
with Cons.prems obtain ti where 1: "Γ,γ,p⊢ ⟨[Rule (MatchAnd m1 (MatchAnd m2 m)) a], s⟩ ⇒ ti" and 2: "Γ,γ,p⊢ ⟨add_match m1 (add_match m2 rs), ti⟩ ⇒ t"
apply(simp add: add_match_split_fst)
apply(erule seqE_cons)
by simp
from 1 r have base: "Γ,γ,p⊢ ⟨[Rule (MatchAnd m2 (MatchAnd m1 m)) a], s⟩ ⇒ ti"
by (metis matches.simps(1) matches_rule_iptables_bigstep)
from 2 Cons.IH have IH: "Γ,γ,p⊢ ⟨add_match m2 (add_match m1 rs), ti⟩ ⇒ t" by simp
from base IH seq'_cons have "Γ,γ,p⊢ ⟨Rule (MatchAnd m2 (MatchAnd m1 m)) a # add_match m2 (add_match m1 rs), s⟩ ⇒ t" by fast
thus ?case using r by(simp add: add_match_split_fst[symmetric])
qed
}
thus ?thesis by blast
qed
lemma add_match_split_fst': "add_match m (a # rs) = add_match m [a] @ add_match m rs"
by (simp add: add_match_split[symmetric])
lemma matches_add_match_simp:
assumes m: "matches γ m p"
shows "Γ,γ,p⊢ ⟨add_match m rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t" (is "?l ⟷ ?r")
proof
assume ?l with m show ?r
proof (induction rs)
case Nil
thus ?case
unfolding add_match_def by simp
next
case (Cons r rs)
hence IH: "Γ,γ,p⊢ ⟨add_match m rs, s⟩ ⇒ t ⟹ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t" by(simp add: add_match_split_fst)
obtain m' a where r: "r = Rule m' a" by (cases r)
with Cons.prems(2) obtain ti where "Γ,γ,p⊢ ⟨[Rule (MatchAnd m m') a], s⟩ ⇒ ti" and "Γ,γ,p⊢ ⟨add_match m rs, ti⟩ ⇒ t"
by(auto elim:seqE_cons simp add: add_match_split_fst)
with Cons.prems(1) IH have "Γ,γ,p⊢ ⟨[Rule m' a], s⟩ ⇒ ti" by(simp add: matches_rule_and_simp)
with ‹Γ,γ,p⊢ ⟨add_match m rs, ti⟩ ⇒ t› IH r show ?case by(metis decision state.exhaust iptables_bigstep_deterministic seq_cons)
qed
next
assume ?r with m show ?l
proof (induction rs)
case Nil
thus ?case
unfolding add_match_def by simp
next
case (Cons r rs)
hence IH: " Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t ⟹ Γ,γ,p⊢ ⟨add_match m rs, s⟩ ⇒ t" by(simp add: add_match_split_fst)
obtain m' a where r: "r = Rule m' a" by (cases r)
with Cons.prems(2) obtain ti where "Γ,γ,p⊢ ⟨[Rule m' a], s⟩ ⇒ ti" and "Γ,γ,p⊢ ⟨rs, ti⟩ ⇒ t"
by(auto elim:seqE_cons simp add: add_match_split_fst)
with Cons.prems(1) IH have "Γ,γ,p⊢ ⟨[Rule (MatchAnd m m') a], s⟩ ⇒ ti" by(simp add: matches_rule_and_simp)
with ‹Γ,γ,p⊢ ⟨rs, ti⟩ ⇒ t› IH r show ?case
apply(simp add: add_match_split_fst)
by(metis decision state.exhaust iptables_bigstep_deterministic seq_cons)
qed
qed
lemma matches_add_match_MatchNot_simp:
assumes m: "matches γ m p"
shows "Γ,γ,p⊢ ⟨add_match (MatchNot m) rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨[], s⟩ ⇒ t" (is "?l s ⟷ ?r s")
proof (cases s)
case Undecided
have "?l Undecided ⟷ ?r Undecided"
proof
assume "?l Undecided" with m show "?r Undecided"
proof (induction rs)
case Nil
thus ?case
unfolding add_match_def by simp
next
case (Cons r rs)
thus ?case
by (cases r) (metis matches_MatchNotAnd_simp skipD seqE_cons add_match_split_fst)
qed
next
assume "?r Undecided" with m show "?l Undecided"
proof (induction rs)
case Nil
thus ?case
unfolding add_match_def by simp
next
case (Cons r rs)
thus ?case
by (cases r) (metis matches_MatchNotAnd_simp skipD seq'_cons add_match_split_fst)
qed
qed
with Undecided show ?thesis by fast
next
case (Decision d)
thus ?thesis
by(metis decision decisionD)
qed
lemma not_matches_add_match_simp:
assumes "¬ matches γ m p"
shows "Γ,γ,p⊢ ⟨add_match m rs, Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨[], Undecided⟩ ⇒ t"
proof(induction rs)
case Nil
thus ?case
unfolding add_match_def by simp
next
case (Cons r rs)
thus ?case
by (cases r) (metis assms add_match_split_fst matches.simps(1) nomatch seq'_cons nomatchD seqE_cons)
qed
lemma iptables_bigstep_add_match_notnot_simp:
"Γ,γ,p⊢ ⟨add_match (MatchNot (MatchNot m)) rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨add_match m rs, s⟩ ⇒ t"
proof(induction rs)
case Nil
thus ?case
unfolding add_match_def by simp
next
case (Cons r rs)
thus ?case
by (cases r)
(metis decision decisionD state.exhaust matches.simps(2) matches_add_match_simp not_matches_add_match_simp)
qed
lemma add_match_match_not_cases:
"Γ,γ,p⊢ ⟨add_match (MatchNot m) rs, Undecided⟩ ⇒ Undecided ⟹ matches γ m p ∨ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided"
by (metis matches.simps(2) matches_add_match_simp)
lemma not_matches_add_matchNot_simp:
"¬ matches γ m p ⟹ Γ,γ,p⊢ ⟨add_match (MatchNot m) rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
by (simp add: matches_add_match_simp)
lemma iptables_bigstep_add_match_and:
"Γ,γ,p⊢ ⟨add_match m1 (add_match m2 rs), s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨add_match (MatchAnd m1 m2) rs, s⟩ ⇒ t"
proof(induction rs arbitrary: s t)
case Nil
thus ?case
unfolding add_match_def by simp
next
case(Cons r rs)
show ?case
proof (cases r, simp only: add_match_split_fst)
fix m a
show "Γ,γ,p⊢ ⟨Rule (MatchAnd m1 (MatchAnd m2 m)) a # add_match m1 (add_match m2 rs), s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨Rule (MatchAnd (MatchAnd m1 m2) m) a # add_match (MatchAnd m1 m2) rs, s⟩ ⇒ t" (is "?l ⟷ ?r")
proof
assume ?l with Cons.IH show ?r
apply -
apply(erule seqE_cons)
apply(case_tac s)
apply(case_tac ti)
apply (metis matches.simps(1) matches_rule_and_simp matches_rule_and_simp_help nomatch seq'_cons)
apply (metis add_match_split_fst matches.simps(1) matches_add_match_simp not_matches_add_match_simp seq_cons)
apply (metis decision decisionD)
done
next
assume ?r with Cons.IH show ?l
apply -
apply(erule seqE_cons)
apply(case_tac s)
apply(case_tac ti)
apply (metis matches.simps(1) matches_rule_and_simp matches_rule_and_simp_help nomatch seq'_cons)
apply (metis add_match_split_fst matches.simps(1) matches_add_match_simp not_matches_add_match_simp seq_cons)
apply (metis decision decisionD)
done
qed
qed
qed
lemma optimize_matches_option_generic:
assumes "∀ r ∈ set rs. P (get_match r)"
and "(⋀m m'. P m ⟹ f m = Some m' ⟹ matches γ m' p = matches γ m p)"
and "(⋀m. P m ⟹ f m = None ⟹ ¬ matches γ m p)"
shows "Γ,γ,p⊢ ⟨optimize_matches_option f rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
(is "?lhs ⟷ ?rhs")
proof
assume ?rhs
from this assms show ?lhs
apply(induction rs s t rule: iptables_bigstep_induct)
apply(auto simp: optimize_matches_option_append intro: iptables_bigstep.intros split: option.split)
done
next
assume ?lhs
from this assms show ?rhs
apply(induction f rs arbitrary: s rule: optimize_matches_option.induct)
apply(simp; fail)
apply(simp split: option.split_asm)
apply(subgoal_tac "¬ matches γ m p")
prefer 2 apply blast
apply (metis decision nomatch seq'_cons state.exhaust)
apply(erule seqE_cons)
apply(rule_tac t=ti in seq'_cons)
apply (meson matches_rule_iptables_bigstep)
by blast
qed
lemma optimize_matches_generic: "∀ r ∈ set rs. P (get_match r) ⟹
(⋀m. P m ⟹ matches γ (f m) p = matches γ m p) ⟹
Γ,γ,p⊢ ⟨optimize_matches f rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
unfolding optimize_matches_def
apply(rule optimize_matches_option_generic)
apply(simp; fail)
apply(simp split: if_split_asm)
apply blast
apply(simp split: if_split_asm)
using matcheq_matchNone_not_matches by fast
end
Theory Ruleset_Update
theory Ruleset_Update
imports Matching
begin
lemma free_return_not_match: "Γ,γ,p⊢ ⟨[Rule m Return], Undecided⟩ ⇒ t ⟹ ¬ matches γ m p"
using no_free_return by fast
subsection‹Background Ruleset Updating›
lemma update_Gamma_nomatch:
assumes "¬ matches γ m p"
shows "Γ(chain ↦ Rule m a # rs),γ,p⊢ ⟨rs', s⟩ ⇒ t ⟷ Γ(chain ↦ rs),γ,p⊢ ⟨rs', s⟩ ⇒ t" (is "?l ⟷ ?r")
proof
assume ?l thus ?r
proof (induction rs' s t rule: iptables_bigstep_induct)
case (Call_return m a chain' rs⇩1 m' rs⇩2)
thus ?case
proof (cases "chain' = chain")
case True
with Call_return show ?thesis
apply simp
apply(cases "rs⇩1")
using assms apply fastforce
apply(rule_tac rs⇩1="list" and m'="m'" and rs⇩2="rs⇩2" in call_return)
apply(simp)
apply(simp)
apply(simp)
apply(simp)
apply(erule seqE_cons[where Γ="(λa. if a = chain then Some rs else Γ a)"])
apply(frule iptables_bigstep_to_undecided[where Γ="(λa. if a = chain then Some rs else Γ a)"])
apply(simp)
done
qed (auto intro: call_return)
next
case (Call_result m' a' chain' rs' t')
have "Γ(chain ↦ rs),γ,p⊢ ⟨[Rule m' (Call chain')], Undecided⟩ ⇒ t'"
proof (cases "chain' = chain")
case True
with Call_result have "Rule m a # rs = rs'" "(Γ(chain ↦ rs)) chain' = Some rs"
by simp+
with assms Call_result show ?thesis
by (metis call_result nomatchD seqE_cons)
next
case False
with Call_result show ?thesis
by (metis call_result fun_upd_apply)
qed
with Call_result show ?case
by fast
qed (auto intro: iptables_bigstep.intros)
next
assume ?r thus ?l
proof (induction rs' s t rule: iptables_bigstep_induct)
case (Call_return m' a' chain' rs⇩1)
thus ?case
proof (cases "chain' = chain")
case True
with Call_return show ?thesis
using assms
by (auto intro: seq_cons nomatch intro!: call_return[where rs⇩1 = "Rule m a # rs⇩1"])
qed (auto intro: call_return)
next
case (Call_result m' a' chain' rs')
thus ?case
proof (cases "chain' = chain")
case True
with Call_result show ?thesis
using assms by (auto intro: seq_cons nomatch intro!: call_result)
qed (auto intro: call_result)
qed (auto intro: iptables_bigstep.intros)
qed
lemma update_Gamma_log_empty:
assumes "a = Log ∨ a = Empty"
shows "Γ(chain ↦ Rule m a # rs),γ,p⊢ ⟨rs', s⟩ ⇒ t ⟷
Γ(chain ↦ rs),γ,p⊢ ⟨rs', s⟩ ⇒ t" (is "?l ⟷ ?r")
proof
assume ?l thus ?r
proof (induction rs' s t rule: iptables_bigstep_induct)
case (Call_return m' a' chain' rs⇩1 m'' rs⇩2)
note [simp] = fun_upd_apply[abs_def]
from Call_return have "Γ(chain ↦ rs),γ,p⊢ ⟨[Rule m' (Call chain')], Undecided⟩ ⇒ Undecided" (is ?Call_return_case)
proof(cases "chain' = chain")
case True with Call_return show ?Call_return_case
proof(cases "rs⇩1")
case Nil with Call_return(3) ‹chain' = chain› assms have "False" by simp
thus ?Call_return_case by simp
next
case (Cons r⇩1 rs⇩1s)
from Cons Call_return have "Γ(chain ↦ rs),γ,p⊢ ⟨r⇩1 # rs⇩1s, Undecided⟩ ⇒ Undecided" by blast
with seqE_cons[where Γ="Γ(chain ↦ rs)"] obtain ti where
"Γ(chain ↦ rs),γ,p⊢ ⟨[r⇩1], Undecided⟩ ⇒ ti" and "Γ(chain ↦ rs),γ,p⊢ ⟨rs⇩1s, ti⟩ ⇒ Undecided" by metis
with iptables_bigstep_to_undecided[where Γ="Γ(chain ↦ rs)"] have "Γ(chain ↦ rs),γ,p⊢ ⟨rs⇩1s, Undecided⟩ ⇒ Undecided" by fast
with Cons Call_return ‹chain' = chain› show ?Call_return_case
apply(rule_tac rs⇩1="rs⇩1s" and m'="m''" and rs⇩2="rs⇩2" in call_return)
apply(simp_all)
done
qed
next
case False with Call_return show ?Call_return_case
by (auto intro: call_return)
qed
thus ?case using Call_return by blast
next
case (Call_result m' a' chain' rs' t')
thus ?case
proof (cases "chain' = chain")
case True
with Call_result have "rs' = [] @ [Rule m a] @ rs"
by simp
with Call_result assms have "Γ(chain ↦ rs),γ,p⊢ ⟨[] @ rs, Undecided⟩ ⇒ t'"
using log_remove empty_empty by fast
hence "Γ(chain ↦ rs),γ,p⊢ ⟨rs, Undecided⟩ ⇒ t'"
by simp
with Call_result True show ?thesis
by (metis call_result fun_upd_same)
qed (fastforce intro: call_result)
qed (auto intro: iptables_bigstep.intros)
next
have cases_a: "⋀P. (a = Log ⟹ P a) ⟹ (a = Empty ⟹ P a) ⟹ P a" using assms by blast
assume ?r thus ?l
proof (induction rs' s t rule: iptables_bigstep_induct)
case (Call_return m' a' chain' rs⇩1 m'' rs⇩2)
from Call_return have xx: "Γ(chain ↦ Rule m a # rs),γ,p⊢ ⟨Rule m a # rs⇩1, Undecided⟩ ⇒ Undecided"
apply -
apply(rule cases_a)
apply (auto intro: nomatch seq_cons intro!: log empty simp del: fun_upd_apply)
done
with Call_return show ?case
proof(cases "chain' = chain")
case False
with Call_return have x: "(Γ(chain ↦ Rule m a # rs)) chain' = Some (rs⇩1 @ Rule m'' Return # rs⇩2)"
by(simp)
with Call_return have "Γ(chain ↦ Rule m a # rs),γ,p⊢ ⟨[Rule m' (Call chain')], Undecided⟩ ⇒ Undecided"
apply -
apply(rule call_return[where rs⇩1="rs⇩1" and m'="m''" and rs⇩2="rs⇩2"])
apply(simp_all add: x xx del: fun_upd_apply)
done
thus "Γ(chain ↦ Rule m a # rs),γ,p⊢ ⟨[Rule m' a'], Undecided⟩ ⇒ Undecided" using Call_return by simp
next
case True
with Call_return have x: "(Γ(chain ↦ Rule m a # rs)) chain' = Some (Rule m a # rs⇩1 @ Rule m'' Return # rs⇩2)"
by(simp)
with Call_return have "Γ(chain ↦ Rule m a # rs),γ,p⊢ ⟨[Rule m' (Call chain')], Undecided⟩ ⇒ Undecided"
apply -
apply(rule call_return[where rs⇩1="Rule m a#rs⇩1" and m'="m''" and rs⇩2="rs⇩2"])
apply(simp_all add: x xx del: fun_upd_apply)
done
thus "Γ(chain ↦ Rule m a # rs),γ,p⊢ ⟨[Rule m' a'], Undecided⟩ ⇒ Undecided" using Call_return by simp
qed
next
case (Call_result ma a chaina rs t)
thus ?case
apply (cases "chaina = chain")
apply(rule cases_a)
apply (auto intro: nomatch seq_cons intro!: log empty call_result)[2]
by (auto intro!: call_result)[1]
qed (auto intro: iptables_bigstep.intros)
qed
lemma map_update_chain_if: "(λb. if b = chain then Some rs else Γ b) = Γ(chain ↦ rs)"
by auto
lemma no_recursive_calls_helper:
assumes "Γ,γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ t"
and "matches γ m p"
and "Γ chain = Some [Rule m (Call chain)]"
shows False
using assms
proof (induction "[Rule m (Call chain)]" Undecided t rule: iptables_bigstep_induct)
case Seq
thus ?case
by (metis Cons_eq_append_conv append_is_Nil_conv skipD)
next
case (Call_return chain' rs⇩1 m' rs⇩2)
hence "rs⇩1 @ Rule m' Return # rs⇩2 = [Rule m (Call chain')]"
by simp
thus ?case
by (cases "rs⇩1") auto
next
case Call_result
thus ?case
by simp
qed (auto intro: iptables_bigstep.intros)
lemma no_recursive_calls:
"Γ(chain ↦ [Rule m (Call chain)]),γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ t ⟹ matches γ m p ⟹ False"
by (fastforce intro: no_recursive_calls_helper)
lemma no_recursive_calls2:
assumes "Γ(chain ↦ (Rule m (Call chain)) # rs''),γ,p⊢ ⟨(Rule m (Call chain)) # rs', Undecided⟩ ⇒ Undecided"
and "matches γ m p"
shows False
using assms
proof (induction "(Rule m (Call chain)) # rs'" Undecided Undecided arbitrary: rs' rule: iptables_bigstep_induct)
case (Seq rs⇩1 rs⇩2 t)
thus ?case
by (cases rs⇩1) (auto elim: seqE_cons simp add: iptables_bigstep_to_undecided)
qed (auto intro: iptables_bigstep.intros simp: Cons_eq_append_conv)
lemma update_Gamma_nochange1:
assumes "Γ(chain ↦ rs),γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ Undecided"
and "Γ(chain ↦ Rule m a # rs),γ,p⊢ ⟨rs', s⟩ ⇒ t"
shows "Γ(chain ↦ rs),γ,p⊢ ⟨rs', s⟩ ⇒ t"
using assms(2) proof (induction rs' s t rule: iptables_bigstep_induct)
case (Call_return m a chaina rs⇩1 m' rs⇩2)
thus ?case
proof (cases "chaina = chain")
case True
with Call_return show ?thesis
apply simp
apply(cases "rs⇩1")
apply(simp)
using assms apply (metis no_free_return)
apply(rule_tac rs⇩1="list" and m'="m'" and rs⇩2="rs⇩2" in call_return)
apply(simp)
apply(simp)
apply(simp)
apply(simp)
apply(erule seqE_cons[where Γ="(λa. if a = chain then Some rs else Γ a)"])
apply(frule iptables_bigstep_to_undecided[where Γ="(λa. if a = chain then Some rs else Γ a)"])
apply(simp)
done
qed (auto intro: call_return)
next
case (Call_result m a chaina rsa t)
thus ?case
proof (cases "chaina = chain")
case True
with Call_result show ?thesis
apply(simp)
apply(cases "rsa")
apply(simp)
apply(rule_tac rs=rs in call_result)
apply(simp_all)
apply(erule_tac seqE_cons[where Γ="(λb. if b = chain then Some rs else Γ b)"])
apply(case_tac t)
apply(simp)
apply(frule iptables_bigstep_to_undecided[where Γ="(λb. if b = chain then Some rs else Γ b)"])
apply(simp)
apply(simp)
apply(subgoal_tac "ti = Undecided")
apply(simp)
using assms(1)[simplified map_update_chain_if[symmetric]] iptables_bigstep_deterministic apply fast
done
qed (fastforce intro: call_result)
qed (auto intro: iptables_bigstep.intros)
lemma update_gamme_remove_Undecidedpart:
assumes "Γ(chain ↦ rs'),γ,p⊢ ⟨rs', Undecided⟩ ⇒ Undecided"
and "Γ(chain ↦ rs1@rs'),γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided"
shows "Γ(chain ↦rs'),γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided"
using assms(2) proof (induction rs Undecided Undecided rule: iptables_bigstep_induct)
case Seq
thus ?case
by (auto simp: iptables_bigstep_to_undecided intro: seq)
next
case (Call_return m a chaina rs⇩1 m' rs⇩2)
thus ?case
apply(cases "chaina = chain")
apply(simp)
apply(cases "length rs1 ≤ length rs⇩1")
apply(simp add: List.append_eq_append_conv_if)
apply(rule_tac rs⇩1="drop (length rs1) rs⇩1" and m'=m' and rs⇩2=rs⇩2 in call_return)
apply(simp_all)[3]
apply(subgoal_tac "rs⇩1 = (take (length rs1) rs⇩1) @ drop (length rs1) rs⇩1")
prefer 2 apply (metis append_take_drop_id)
apply(clarify)
apply(subgoal_tac "Γ(chain ↦ drop (length rs1) rs⇩1 @ Rule m' Return # rs⇩2),γ,p⊢
⟨(take (length rs1) rs⇩1) @ drop (length rs1) rs⇩1, Undecided⟩ ⇒ Undecided")
prefer 2 apply(auto)[1]
apply(erule_tac rs⇩1="take (length rs1) rs⇩1" and rs⇩2="drop (length rs1) rs⇩1" in seqE)
apply(simp)
apply(frule_tac rs="drop (length rs1) rs⇩1" in iptables_bigstep_to_undecided)
apply(simp; fail)
using assms apply (auto intro: call_result call_return)
done
next
case (Call_result _ _ chain' rsa)
thus ?case
apply(cases "chain' = chain")
apply(simp)
apply(rule call_result)
apply(simp_all)[2]
apply (metis iptables_bigstep_to_undecided seqE)
apply (auto intro: call_result)
done
qed (auto intro: iptables_bigstep.intros)
lemma update_Gamma_nocall:
assumes "¬ (∃chain. a = Call chain)"
shows "Γ,γ,p⊢ ⟨[Rule m a], s⟩ ⇒ t ⟷ Γ',γ,p⊢ ⟨[Rule m a], s⟩ ⇒ t"
proof -
{
fix Γ Γ'
have "Γ,γ,p⊢ ⟨[Rule m a], s⟩ ⇒ t ⟹ Γ',γ,p⊢ ⟨[Rule m a], s⟩ ⇒ t"
proof (induction "[Rule m a]" s t rule: iptables_bigstep_induct)
case Seq
thus ?case by (metis (lifting, no_types) list_app_singletonE[where x = "Rule m a"] skipD)
next
case Call_return thus ?case using assms by metis
next
case Call_result thus ?case using assms by metis
qed (auto intro: iptables_bigstep.intros)
}
thus ?thesis
by blast
qed
lemma update_Gamma_call:
assumes "Γ chain = Some rs" and "Γ' chain = Some rs'"
assumes "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided" and "Γ',γ,p⊢ ⟨rs', Undecided⟩ ⇒ Undecided"
shows "Γ,γ,p⊢ ⟨[Rule m (Call chain)], s⟩ ⇒ t ⟷ Γ',γ,p⊢ ⟨[Rule m (Call chain)], s⟩ ⇒ t"
proof -
{
fix Γ Γ' rs rs'
assume assms:
"Γ chain = Some rs" "Γ' chain = Some rs'"
"Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided" "Γ',γ,p⊢ ⟨rs', Undecided⟩ ⇒ Undecided"
have "Γ,γ,p⊢ ⟨[Rule m (Call chain)], s⟩ ⇒ t ⟹ Γ',γ,p⊢ ⟨[Rule m (Call chain)], s⟩ ⇒ t"
proof (induction "[Rule m (Call chain)]" s t rule: iptables_bigstep_induct)
case Seq
thus ?case by (metis (lifting, no_types) list_app_singletonE[where x = "Rule m (Call chain)"] skipD)
next
case Call_result
thus ?case
using assms by (metis call_result iptables_bigstep_deterministic)
qed (auto intro: iptables_bigstep.intros assms)
}
note * = this
show ?thesis
using *[OF assms(1-4)] *[OF assms(2,1,4,3)] by blast
qed
lemma update_Gamma_remove_call_undecided:
assumes "Γ(chain ↦ Rule m (Call foo) # rs'),γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided"
and "matches γ m p"
shows "Γ(chain ↦ rs'),γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided"
using assms
proof (induction rs Undecided Undecided arbitrary: rule: iptables_bigstep_induct)
case Seq
thus ?case
by (force simp: iptables_bigstep_to_undecided intro: seq')
next
case (Call_return m a chaina rs⇩1 m' rs⇩2)
thus ?case
apply(cases "chaina = chain")
apply(cases "rs⇩1")
apply(force intro: call_return)
apply(simp)
apply(erule_tac Γ="Γ(chain ↦ list @ Rule m' Return # rs⇩2)" in seqE_cons)
apply(frule_tac Γ="Γ(chain ↦ list @ Rule m' Return # rs⇩2)" in iptables_bigstep_to_undecided)
apply(auto intro: call_return)
done
next
case (Call_result m a chaina rsa)
thus ?case
apply(cases "chaina = chain")
apply(simp)
apply (metis call_result fun_upd_same iptables_bigstep_to_undecided seqE_cons)
apply (auto intro: call_result)
done
qed (auto intro: iptables_bigstep.intros)
lemma all_return_subchain:
assumes a1: "Γ chain = Some rs"
and a2: "matches γ m p"
and a3: "∀r∈set rs. get_action r = Return"
shows "Γ,γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Undecided"
proof (cases "∃r ∈ set rs. matches γ (get_match r) p")
case True
hence "(∃rs1 r rs2. rs = rs1 @ r # rs2 ∧ matches γ (get_match r) p ∧ (∀r'∈set rs1. ¬ matches γ (get_match r') p))"
by (subst split_list_first_prop_iff[symmetric])
then obtain rs1 r rs2
where *: "rs = rs1 @ r # rs2" "matches γ (get_match r) p" "∀r'∈set rs1. ¬ matches γ (get_match r') p"
by auto
with a3 obtain m' where "r = Rule m' Return"
by (cases r) simp
with * assms show ?thesis
by (fastforce intro: call_return nomatch')
next
case False
hence "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided"
by (blast intro: nomatch')
with a1 a2 show ?thesis
by (metis call_result)
qed
lemma get_action_case_simp: "get_action (case r of Rule m' x ⇒ Rule (MatchAnd m m') x) = get_action r"
by (metis rule.case_eq_if rule.sel(2))
lemma updategamma_insert_new: "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t ⟹ chain ∉ dom Γ ⟹ Γ(chain ↦ rs'),γ,p⊢ ⟨rs, s⟩ ⇒ t"
proof(induction rule: iptables_bigstep_induct)
case (Call_result m a chain' rs t)
thus ?case by (metis call_result domI fun_upd_def)
next
case Call_return
thus ?case by (metis call_return domI fun_upd_def)
qed(auto intro: iptables_bigstep.intros)
end
Theory Call_Return_Unfolding
theory Call_Return_Unfolding
imports Matching Ruleset_Update
"Common/Repeat_Stabilize"
begin
section‹@{term Call} @{term Return} Unfolding›
text‹Remove @{term Return}s›
fun process_ret :: "'a rule list ⇒ 'a rule list" where
"process_ret [] = []" |
"process_ret (Rule m Return # rs) = add_match (MatchNot m) (process_ret rs)" |
"process_ret (r#rs) = r # process_ret rs"
text‹Remove @{term Call}s›
fun process_call :: "'a ruleset ⇒ 'a rule list ⇒ 'a rule list" where
"process_call Γ [] = []" |
"process_call Γ (Rule m (Call chain) # rs) = add_match m (process_ret (the (Γ chain))) @ process_call Γ rs" |
"process_call Γ (r#rs) = r # process_call Γ rs"
lemma process_ret_split_fst_Return:
"a = Return ⟹ process_ret (Rule m a # rs) = add_match (MatchNot m) (process_ret rs)"
by auto
lemma process_ret_split_fst_NeqReturn:
"a ≠ Return ⟹ process_ret((Rule m a) # rs) = (Rule m a) # (process_ret rs)"
by (cases a) auto
lemma add_match_simp: "add_match m = map (λr. Rule (MatchAnd m (get_match r)) (get_action r))"
by (auto simp: add_match_def cong: map_cong split: rule.split)
definition add_missing_ret_unfoldings :: "'a rule list ⇒ 'a rule list ⇒ 'a rule list" where
"add_missing_ret_unfoldings rs1 rs2 ≡
foldr (λrf acc. add_match (MatchNot (get_match rf)) ∘ acc) [r←rs1. get_action r = Return] id rs2"
fun MatchAnd_foldr :: "'a match_expr list ⇒ 'a match_expr" where
"MatchAnd_foldr [] = undefined" |
"MatchAnd_foldr [e] = e" |
"MatchAnd_foldr (e # es) = MatchAnd e (MatchAnd_foldr es)"
fun add_match_MatchAnd_foldr :: "'a match_expr list ⇒ ('a rule list ⇒ 'a rule list)" where
"add_match_MatchAnd_foldr [] = id" |
"add_match_MatchAnd_foldr es = add_match (MatchAnd_foldr es)"
lemma add_match_add_match_MatchAnd_foldr:
"Γ,γ,p⊢ ⟨add_match m (add_match_MatchAnd_foldr ms rs2), s⟩ ⇒ t = Γ,γ,p⊢ ⟨add_match (MatchAnd_foldr (m#ms)) rs2, s⟩ ⇒ t"
proof (induction ms)
case Nil
show ?case by (simp add: add_match_def)
next
case Cons
thus ?case by (simp add: iptables_bigstep_add_match_and)
qed
lemma add_match_MatchAnd_foldr_empty_rs2: "add_match_MatchAnd_foldr ms [] = []"
by (induction ms) (simp_all add: add_match_def)
lemma add_missing_ret_unfoldings_alt: "Γ,γ,p⊢ ⟨add_missing_ret_unfoldings rs1 rs2, s⟩ ⇒ t ⟷
Γ,γ,p⊢ ⟨(add_match_MatchAnd_foldr (map (λr. MatchNot (get_match r)) [r←rs1. get_action r = Return])) rs2, s ⟩ ⇒ t"
proof(induction rs1)
case Nil
thus ?case
unfolding add_missing_ret_unfoldings_def by simp
next
case (Cons r rs)
from Cons obtain m a where "r = Rule m a" by(cases r) (simp)
with Cons show ?case
unfolding add_missing_ret_unfoldings_def
apply(cases "matches γ m p")
apply (simp_all add: matches_add_match_simp matches_add_match_MatchNot_simp add_match_add_match_MatchAnd_foldr[symmetric])
done
qed
lemma add_match_add_missing_ret_unfoldings_rot:
"Γ,γ,p⊢ ⟨add_match m (add_missing_ret_unfoldings rs1 rs2), s⟩ ⇒ t =
Γ,γ,p⊢ ⟨add_missing_ret_unfoldings (Rule (MatchNot m) Return#rs1) rs2, s⟩ ⇒ t"
by(simp add: add_missing_ret_unfoldings_def iptables_bigstep_add_match_notnot_simp)
subsection‹Completeness›
lemma process_ret_split_obvious: "process_ret (rs⇩1 @ rs⇩2) =
(process_ret rs⇩1) @ (add_missing_ret_unfoldings rs⇩1 (process_ret rs⇩2))"
unfolding add_missing_ret_unfoldings_def
proof (induction rs⇩1 arbitrary: rs⇩2)
case (Cons r rs)
from Cons obtain m a where "r = Rule m a" by (cases r) simp
with Cons.IH show ?case
apply(cases a)
apply(simp_all add: add_match_split)
done
qed simp
lemma add_missing_ret_unfoldings_emptyrs2: "add_missing_ret_unfoldings rs1 [] = []"
unfolding add_missing_ret_unfoldings_def
by (induction rs1) (simp_all add: add_match_def)
lemma process_call_split: "process_call Γ (rs1 @ rs2) = process_call Γ rs1 @ process_call Γ rs2"
proof (induction rs1)
case (Cons r rs1)
thus ?case
apply(cases r, rename_tac m a)
apply(case_tac a)
apply(simp_all)
done
qed simp
lemma process_call_split_fst: "process_call Γ (a # rs) = process_call Γ [a] @ process_call Γ rs"
by (simp add: process_call_split[symmetric])
lemma iptables_bigstep_process_ret_undecided: "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ t ⟹ Γ,γ,p⊢ ⟨process_ret rs, Undecided⟩ ⇒ t"
proof (induction rs)
case (Cons r rs)
show ?case
proof (cases r)
case (Rule m' a')
show "Γ,γ,p⊢ ⟨process_ret (r # rs), Undecided⟩ ⇒ t"
proof (cases a')
case Accept
with Cons Rule show ?thesis
by simp (metis acceptD decision decisionD nomatchD seqE_cons seq_cons)
next
case Drop
with Cons Rule show ?thesis
by simp (metis decision decisionD dropD nomatchD seqE_cons seq_cons)
next
case Log
with Cons Rule show ?thesis
by simp (metis logD nomatchD seqE_cons seq_cons)
next
case Reject
with Cons Rule show ?thesis
by simp (metis decision decisionD nomatchD rejectD seqE_cons seq_cons)
next
case (Call chain)
from Cons.prems obtain ti where 1:"Γ,γ,p⊢ ⟨[r], Undecided⟩ ⇒ ti" and 2: "Γ,γ,p⊢ ⟨rs, ti⟩ ⇒ t" using seqE_cons by metis
thus ?thesis
proof(cases ti)
case Undecided
with Cons.IH 2 have IH: "Γ,γ,p⊢ ⟨process_ret rs, Undecided⟩ ⇒ t" by simp
from Undecided 1 Call Rule have "Γ,γ,p⊢ ⟨[Rule m' (Call chain)], Undecided⟩ ⇒ Undecided" by simp
with IH have" Γ,γ,p⊢ ⟨Rule m' (Call chain) # process_ret rs, Undecided⟩ ⇒ t" using seq'_cons by fast
thus ?thesis using Rule Call by force
next
case (Decision X)
with 1 Rule Call have "Γ,γ,p⊢ ⟨[Rule m' (Call chain)], Undecided⟩ ⇒ Decision X" by simp
moreover from 2 Decision have "t = Decision X" using decisionD by fast
moreover from decision have "Γ,γ,p⊢ ⟨process_ret rs, Decision X⟩ ⇒ Decision X" by fast
ultimately show ?thesis using seq_cons by (metis Call Rule process_ret.simps(7))
qed
next
case Return
with Cons Rule show ?thesis
by simp (metis matches.simps(2) matches_add_match_simp no_free_return nomatchD seqE_cons)
next
case Empty
show ?thesis
apply (insert Empty Cons Rule)
apply(erule seqE_cons)
apply (rename_tac ti)
apply(case_tac ti)
apply (simp add: seq_cons)
apply (metis Rule_DecisionE emptyD state.distinct(1))
done
next
case Unknown
show ?thesis using Unknown_actions_False
by (metis Cons.IH Cons.prems Rule Unknown nomatchD process_ret.simps(10) seqE_cons seq_cons)
next
case Goto thus ?thesis using Unknown_actions_False
by (metis Cons.IH Cons.prems Rule Goto nomatchD process_ret.simps(8) seqE_cons seq_cons)
qed
qed
qed simp
lemma add_match_rot_add_missing_ret_unfoldings:
"Γ,γ,p⊢ ⟨add_match m (add_missing_ret_unfoldings rs1 rs2), Undecided⟩ ⇒ Undecided =
Γ,γ,p⊢ ⟨add_missing_ret_unfoldings rs1 (add_match m rs2), Undecided⟩ ⇒ Undecided"
apply(simp add: add_missing_ret_unfoldings_alt add_match_add_missing_ret_unfoldings_rot add_match_add_match_MatchAnd_foldr[symmetric] iptables_bigstep_add_match_notnot_simp)
apply(cases "map (λr. MatchNot (get_match r)) [r←rs1 . (get_action r) = Return]")
apply(simp_all add: add_match_distrib)
done
text ‹Completeness›
theorem unfolding_complete: "Γ,γ,p⊢ ⟨rs,s⟩ ⇒ t ⟹ Γ,γ,p⊢ ⟨process_call Γ rs,s⟩ ⇒ t"
proof (induction rule: iptables_bigstep_induct)
case (Nomatch m a)
thus ?case
by (cases a) (auto intro: iptables_bigstep.intros simp add: not_matches_add_match_simp skip)
next
case Seq
thus ?case
by(simp add: process_call_split seq')
next
case (Call_return m a chain rs⇩1 m' rs⇩2)
hence "Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided"
by simp
hence "Γ,γ,p⊢ ⟨process_ret rs⇩1, Undecided⟩ ⇒ Undecided"
by (rule iptables_bigstep_process_ret_undecided)
with Call_return have "Γ,γ,p⊢ ⟨process_ret rs⇩1 @ add_missing_ret_unfoldings rs⇩1 (add_match (MatchNot m') (process_ret rs⇩2)), Undecided⟩ ⇒ Undecided"
by (metis matches_add_match_MatchNot_simp skip add_match_rot_add_missing_ret_unfoldings seq')
with Call_return show ?case
by (simp add: matches_add_match_simp process_ret_split_obvious)
next
case Call_result
thus ?case
by (simp add: matches_add_match_simp iptables_bigstep_process_ret_undecided)
qed (auto intro: iptables_bigstep.intros)
lemma process_ret_cases:
"process_ret rs = rs ∨ (∃rs⇩1 rs⇩2 m. rs = rs⇩1@[Rule m Return]@rs⇩2 ∧ (process_ret rs) = rs⇩1@(process_ret ([Rule m Return]@rs⇩2)))"
proof (induction rs)
case (Cons r rs)
thus ?case
apply(cases r, rename_tac m' a')
apply(case_tac a')
apply(simp_all)
apply(erule disjE,simp,rule disjI2,elim exE,simp add: process_ret_split_obvious,
metis append_Cons process_ret_split_obvious process_ret.simps(2))+
apply(rule disjI2)
apply(rule_tac x="[]" in exI)
apply(rule_tac x="rs" in exI)
apply(rule_tac x="m'" in exI)
apply(simp)
apply(erule disjE,simp,rule disjI2,elim exE,simp add: process_ret_split_obvious,
metis append_Cons process_ret_split_obvious process_ret.simps(2))+
done
qed simp
lemma process_ret_splitcases:
obtains (id) "process_ret rs = rs"
| (split) rs⇩1 rs⇩2 m where "rs = rs⇩1@[Rule m Return]@rs⇩2" and "process_ret rs = rs⇩1@(process_ret ([Rule m Return]@rs⇩2))"
by (metis process_ret_cases)
lemma iptables_bigstep_process_ret_cases3:
assumes "Γ,γ,p⊢ ⟨process_ret rs, Undecided⟩ ⇒ Undecided"
obtains (noreturn) "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided"
| (return) rs⇩1 rs⇩2 m where "rs = rs⇩1@[Rule m Return]@rs⇩2" "Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided" "matches γ m p"
proof -
have "Γ,γ,p⊢ ⟨process_ret rs, Undecided⟩ ⇒ Undecided ⟹
(Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided) ∨
(∃rs⇩1 rs⇩2 m. rs = rs⇩1@[Rule m Return]@rs⇩2 ∧ Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided ∧ matches γ m p)"
proof (induction rs)
case Nil thus ?case by simp
next
case (Cons r rs)
from Cons obtain m a where r: "r = Rule m a" by (cases r) simp
from r Cons show ?case
proof(cases "a ≠ Return")
case True
with r Cons.prems have prems_r: "Γ,γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒ Undecided " and prems_rs: "Γ,γ,p⊢ ⟨process_ret rs, Undecided⟩ ⇒ Undecided"
apply(simp_all add: process_ret_split_fst_NeqReturn)
apply(erule seqE_cons, frule iptables_bigstep_to_undecided, simp)+
done
from prems_rs Cons.IH have "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided ∨
(∃rs⇩1 rs⇩2 m. rs = rs⇩1 @ [Rule m Return] @ rs⇩2 ∧ Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided ∧ matches γ m p)" by simp
thus "Γ,γ,p⊢ ⟨r # rs, Undecided⟩ ⇒ Undecided ∨ (∃rs⇩1 rs⇩2 m. r # rs = rs⇩1 @ [Rule m Return] @ rs⇩2 ∧ Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided ∧ matches γ m p)"
proof(elim disjE)
assume "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided"
hence "Γ,γ,p⊢ ⟨r # rs, Undecided⟩ ⇒ Undecided" using prems_r by (metis r seq'_cons)
thus ?thesis by simp
next
assume "(∃rs⇩1 rs⇩2 m. rs = rs⇩1 @ [Rule m Return] @ rs⇩2 ∧ Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided ∧ matches γ m p)"
from this obtain rs⇩1 rs⇩2 m' where "rs = rs⇩1 @ [Rule m' Return] @ rs⇩2" and "Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided" and "matches γ m' p" by blast
hence "∃rs⇩1 rs⇩2 m. r # rs = rs⇩1 @ [Rule m Return] @ rs⇩2 ∧ Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided ∧ matches γ m p"
apply(rule_tac x="Rule m a # rs⇩1" in exI)
apply(rule_tac x=rs⇩2 in exI)
apply(rule_tac x=m' in exI)
apply(simp add: r)
using prems_r seq'_cons by fast
thus ?thesis by simp
qed
next
case False
hence "a = Return" by simp
with Cons.prems r have prems: "Γ,γ,p⊢ ⟨add_match (MatchNot m) (process_ret rs), Undecided⟩ ⇒ Undecided" by simp
show "Γ,γ,p⊢ ⟨r # rs, Undecided⟩ ⇒ Undecided ∨ (∃rs⇩1 rs⇩2 m. r # rs = rs⇩1 @ [Rule m Return] @ rs⇩2 ∧ Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided ∧ matches γ m p)"
proof(cases "matches γ m p")
case True
hence "∃rs⇩1 rs⇩2 m. r # rs = rs⇩1 @ Rule m Return # rs⇩2 ∧ Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided ∧ matches γ m p"
apply(rule_tac x="[]" in exI)
apply(rule_tac x="rs" in exI)
apply(rule_tac x="m" in exI)
apply(simp add: skip r ‹a = Return›)
done
thus ?thesis by simp
next
case False
with nomatch seq_cons False r have r_nomatch: "⋀rs. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided ⟹ Γ,γ,p⊢ ⟨r # rs, Undecided⟩ ⇒ Undecided" by fast
note r_nomatch'=r_nomatch[simplified r ‹a = Return›]
from False not_matches_add_matchNot_simp prems have "Γ,γ,p⊢ ⟨process_ret rs, Undecided⟩ ⇒ Undecided" by fast
with Cons.IH have IH: "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided ∨ (∃rs⇩1 rs⇩2 m. rs = rs⇩1 @ [Rule m Return] @ rs⇩2 ∧ Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided ∧ matches γ m p)" .
thus ?thesis
proof(elim disjE)
assume "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided"
hence "Γ,γ,p⊢ ⟨r # rs, Undecided⟩ ⇒ Undecided" using r_nomatch by simp
thus ?thesis by simp
next
assume "∃rs⇩1 rs⇩2 m. rs = rs⇩1 @ [Rule m Return] @ rs⇩2 ∧ Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided ∧ matches γ m p"
from this obtain rs⇩1 rs⇩2 m' where "rs = rs⇩1 @ [Rule m' Return] @ rs⇩2" and "Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided" and "matches γ m' p" by blast
hence "∃rs⇩1 rs⇩2 m. r # rs = rs⇩1 @ [Rule m Return] @ rs⇩2 ∧ Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒ Undecided ∧ matches γ m p"
apply(rule_tac x="Rule m Return # rs⇩1" in exI)
apply(rule_tac x="rs⇩2" in exI)
apply(rule_tac x="m'" in exI)
by(simp add: ‹a = Return› False r r_nomatch')
thus ?thesis by simp
qed
qed
qed
qed
with assms noreturn return show ?thesis by auto
qed
lemma iptables_bigstep_process_ret_DecisionD: "Γ,γ,p⊢ ⟨process_ret rs, s⟩ ⇒ Decision X ⟹ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ Decision X"
proof (induction rs arbitrary: s)
case (Cons r rs)
thus ?case
apply(cases r, rename_tac m a)
apply(clarify)
apply(case_tac "a ≠ Return")
apply(simp add: process_ret_split_fst_NeqReturn)
apply(erule seqE_cons)
apply(simp add: seq'_cons)
apply(simp)
apply(case_tac "matches γ m p")
apply(simp add: matches_add_match_MatchNot_simp skip)
apply (metis decision skipD)
apply(simp add: not_matches_add_matchNot_simp)
by (metis decision state.exhaust nomatch seq'_cons)
qed simp
subsection‹@{const process_ret} correctness›
lemma process_ret_add_match_dist1: "Γ,γ,p⊢ ⟨process_ret (add_match m rs), s⟩ ⇒ t ⟹ Γ,γ,p⊢ ⟨add_match m (process_ret rs), s⟩ ⇒ t"
apply(induction rs arbitrary: s t)
apply(simp add: add_match_def)
apply(rename_tac r rs s t)
apply(case_tac r)
apply(rename_tac m' a')
apply(simp)
apply(case_tac a')
apply(simp_all add: add_match_split_fst)
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(erule seqE_cons)
using seq' apply(fastforce)
defer
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(case_tac "matches γ (MatchNot (MatchAnd m m')) p")
apply(simp)
apply (meson seq'_cons seqE_cons)
apply (meson seq'_cons seqE_cons)
by (metis decision decisionD matches.simps(1) matches_add_match_MatchNot_simp matches_add_match_simp
not_matches_add_matchNot_simp not_matches_add_match_simp state.exhaust)
lemma process_ret_add_match_dist2: "Γ,γ,p⊢ ⟨add_match m (process_ret rs), s⟩ ⇒ t ⟹ Γ,γ,p⊢ ⟨process_ret (add_match m rs), s⟩ ⇒ t"
apply(induction rs arbitrary: s t)
apply(simp add: add_match_def)
apply(rename_tac r rs s t)
apply(case_tac r)
apply(rename_tac m' a')
apply(simp)
apply(case_tac a')
apply(simp_all add: add_match_split_fst)
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(erule seqE_cons)
using seq' apply(fastforce)
defer
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(erule seqE_cons)
using seq' apply(fastforce)
apply(case_tac "matches γ (MatchNot (MatchAnd m m')) p")
apply(simp)
apply (meson seq'_cons seqE_cons)
apply (meson seq'_cons seqE_cons)
by (metis decision decisionD matches.simps(1) matches_add_match_MatchNot_simp matches_add_match_simp
not_matches_add_matchNot_simp not_matches_add_match_simp state.exhaust)
lemma process_ret_add_match_dist: "Γ,γ,p⊢ ⟨process_ret (add_match m rs), s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨add_match m (process_ret rs), s⟩ ⇒ t"
by (metis process_ret_add_match_dist1 process_ret_add_match_dist2)
lemma process_ret_Undecided_sound:
assumes "Γ(chain ↦ rs),γ,p⊢ ⟨process_ret (add_match m rs), Undecided⟩ ⇒ Undecided"
shows "Γ(chain ↦ rs),γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Undecided"
proof (cases "matches γ m p")
case False
thus ?thesis
by (metis nomatch)
next
case True
note matches = this
show ?thesis
using assms proof (induction rs)
case Nil
from call_result[OF matches, where Γ="Γ(chain ↦ [])"]
have "(Γ(chain ↦ [])) chain = Some [] ⟹ Γ(chain ↦ []),γ,p⊢ ⟨[], Undecided⟩ ⇒ Undecided ⟹ Γ(chain ↦ []),γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Undecided"
by simp
thus ?case
by (fastforce intro: skip)
next
case (Cons r rs)
obtain m' a' where r: "r = Rule m' a'" by (cases r) blast
with Cons.prems have prems: "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨process_ret (add_match m (Rule m' a' # rs)), Undecided⟩ ⇒ Undecided"
by fast
hence prems_simplified: "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨process_ret (Rule m' a' # rs), Undecided⟩ ⇒ Undecided"
using matches by (metis matches_add_match_simp process_ret_add_match_dist)
have "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Undecided"
proof (cases "a' = Return")
case True
note a' = this
have "Γ(chain ↦ Rule m' Return # rs),γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Undecided"
proof (cases "matches γ m' p")
case True
with matches show ?thesis
by (fastforce intro: call_return skip)
next
case False
note matches' = this
hence "Γ(chain ↦ rs),γ,p⊢ ⟨process_ret (Rule m' a' # rs), Undecided⟩ ⇒ Undecided"
by (metis prems_simplified update_Gamma_nomatch)
with a' have "Γ(chain ↦ rs),γ,p⊢ ⟨add_match (MatchNot m') (process_ret rs), Undecided⟩ ⇒ Undecided"
by simp
with matches matches' have "Γ(chain ↦ rs),γ,p⊢ ⟨add_match m (process_ret rs), Undecided⟩ ⇒ Undecided"
by (simp add: matches_add_match_simp not_matches_add_matchNot_simp)
with matches' Cons.IH show ?thesis
by (fastforce simp: update_Gamma_nomatch process_ret_add_match_dist)
qed
with a' show ?thesis
by simp
next
case False
note a' = this
with prems_simplified have "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨Rule m' a' # process_ret rs, Undecided⟩ ⇒ Undecided"
by (simp add: process_ret_split_fst_NeqReturn)
hence step: "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨[Rule m' a'], Undecided⟩ ⇒ Undecided"
and IH_pre: "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨process_ret rs, Undecided⟩ ⇒ Undecided"
by (metis seqE_cons iptables_bigstep_to_undecided)+
from step have "Γ(chain ↦ rs),γ,p⊢ ⟨process_ret rs, Undecided⟩ ⇒ Undecided"
proof (cases rule: Rule_UndecidedE)
case log thus ?thesis
using IH_pre by (metis empty iptables_bigstep.log update_Gamma_nochange1 update_Gamma_nomatch)
next
case call thus ?thesis
using IH_pre by (metis update_Gamma_remove_call_undecided)
next
case nomatch thus ?thesis
using IH_pre by (metis update_Gamma_nomatch)
qed
hence "Γ(chain ↦ rs),γ,p⊢ ⟨process_ret (add_match m rs), Undecided⟩ ⇒ Undecided"
by (metis matches matches_add_match_simp process_ret_add_match_dist)
with Cons.IH have IH: "Γ(chain ↦ rs),γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Undecided"
by fast
from step show ?thesis
proof (cases rule: Rule_UndecidedE)
case log thus ?thesis using IH
by (simp add: update_Gamma_log_empty)
next
case nomatch
thus ?thesis
using IH by (metis update_Gamma_nomatch)
next
case (call c)
let ?Γ' = "Γ(chain ↦ Rule m' a' # rs)"
from IH_pre show ?thesis
proof (cases rule: iptables_bigstep_process_ret_cases3)
case noreturn
with call have "?Γ',γ,p⊢ ⟨Rule m' (Call c) # rs, Undecided⟩ ⇒ Undecided"
by (metis step seq_cons)
from call have "?Γ' chain = Some (Rule m' (Call c) # rs)"
by simp
from matches show ?thesis
by (rule call_result) fact+
next
case (return rs⇩1 rs⇩2 new_m')
with call have "?Γ' chain = Some ((Rule m' (Call c) # rs⇩1) @ [Rule new_m' Return] @ rs⇩2)"
by simp
from call return step have "?Γ',γ,p⊢ ⟨Rule m' (Call c) # rs⇩1, Undecided⟩ ⇒ Undecided"
using IH_pre by (auto intro: seq_cons)
from matches show ?thesis
by (rule call_return) fact+
qed
qed
qed
thus ?case
by (metis r)
qed
qed
lemma process_ret_Decision_sound:
assumes "Γ(chain ↦ rs),γ,p⊢ ⟨process_ret (add_match m rs), Undecided⟩ ⇒ Decision X"
shows "Γ(chain ↦ rs),γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Decision X"
proof (cases "matches γ m p")
case False
thus ?thesis by (metis assms state.distinct(1) not_matches_add_match_simp process_ret_add_match_dist1 skipD)
next
case True
note matches = this
show ?thesis
using assms proof (induction rs)
case Nil
hence False by (metis add_match_split append_self_conv state.distinct(1) process_ret.simps(1) skipD)
thus ?case by simp
next
case (Cons r rs)
obtain m' a' where r: "r = Rule m' a'" by (cases r) blast
with Cons.prems have prems: "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨process_ret (add_match m (Rule m' a' # rs)), Undecided⟩ ⇒ Decision X"
by fast
hence prems_simplified: "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨process_ret (Rule m' a' # rs), Undecided⟩ ⇒ Decision X"
using matches by (metis matches_add_match_simp process_ret_add_match_dist)
have "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Decision X"
proof (cases "a' = Return")
case True
note a' = this
have "Γ(chain ↦ Rule m' Return # rs),γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Decision X"
proof (cases "matches γ m' p")
case True
with matches prems_simplified a' show ?thesis
by (auto simp: not_matches_add_match_simp dest: skipD)
next
case False
note matches' = this
with prems_simplified have "Γ(chain ↦ rs),γ,p⊢ ⟨process_ret (Rule m' a' # rs), Undecided⟩ ⇒ Decision X"
by (metis update_Gamma_nomatch)
with a' matches matches' have "Γ(chain ↦ rs),γ,p⊢ ⟨add_match m (process_ret rs), Undecided⟩ ⇒ Decision X"
by (simp add: matches_add_match_simp not_matches_add_matchNot_simp)
with matches matches' Cons.IH show ?thesis
by (fastforce simp: update_Gamma_nomatch process_ret_add_match_dist matches_add_match_simp not_matches_add_matchNot_simp)
qed
with a' show ?thesis
by simp
next
case False
with prems_simplified obtain ti
where step: "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨[Rule m' a'], Undecided⟩ ⇒ ti"
and IH_pre: "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨process_ret rs, ti⟩ ⇒ Decision X"
by (auto simp: process_ret_split_fst_NeqReturn elim: seqE_cons)
hence "Γ(chain ↦ Rule m' a' # rs),γ,p⊢ ⟨rs, ti⟩ ⇒ Decision X"
by (metis iptables_bigstep_process_ret_DecisionD)
thus ?thesis
using matches step by (force intro: call_result seq'_cons)
qed
thus ?case
by (metis r)
qed
qed
lemma process_ret_result_empty: "[] = process_ret rs ⟹ ∀r ∈ set rs. get_action r = Return"
proof (induction rs)
case (Cons r rs)
thus ?case
apply(simp)
apply(case_tac r)
apply(rename_tac m a)
apply(case_tac a)
apply(simp_all add: add_match_def)
done
qed simp
lemma process_ret_sound':
assumes "Γ(chain ↦ rs),γ,p⊢ ⟨process_ret (add_match m rs), Undecided⟩ ⇒ t"
shows "Γ(chain ↦ rs),γ,p⊢ ⟨[Rule m (Call chain)], Undecided⟩ ⇒ t"
using assms by (metis state.exhaust process_ret_Undecided_sound process_ret_Decision_sound)
lemma wf_chain_process_ret: "wf_chain Γ rs ⟹ wf_chain Γ (process_ret rs)"
apply(induction rs)
apply(simp add: wf_chain_def add_match_def)
apply(case_tac a)
apply(case_tac "x2 ≠ Return")
apply(simp add: process_ret_split_fst_NeqReturn)
using wf_chain_append apply (metis Cons_eq_appendI append_Nil)
apply(simp add: process_ret_split_fst_Return)
apply(simp add: wf_chain_def add_match_def get_action_case_simp)
done
lemma wf_chain_add_match: "wf_chain Γ rs ⟹ wf_chain Γ (add_match m rs)"
by(induction rs) (simp_all add: wf_chain_def add_match_def get_action_case_simp)
subsection‹Soundness›
theorem unfolding_sound: "wf_chain Γ rs ⟹ Γ,γ,p⊢ ⟨process_call Γ rs, s⟩ ⇒ t ⟹ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
proof (induction rs arbitrary: s t)
case (Cons r rs)
thus ?case
apply -
apply(subst(asm) process_call_split_fst)
apply(erule seqE)
unfolding wf_chain_def
apply(case_tac r, rename_tac m a)
apply(case_tac a)
apply(simp_all add: seq'_cons)
apply(case_tac s)
defer
apply (metis decision decisionD)
apply(case_tac "matches γ m p")
defer
apply(simp add: not_matches_add_match_simp)
apply(drule skipD, simp)
apply (metis nomatch seq_cons)
apply(clarify)
apply(simp add: matches_add_match_simp)
apply(rule_tac t=ti in seq_cons)
apply(simp_all)
using process_ret_sound'
by (metis fun_upd_triv matches_add_match_simp process_ret_add_match_dist)
qed simp
corollary unfolding_sound_complete: "wf_chain Γ rs ⟹ Γ,γ,p⊢ ⟨process_call Γ rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
by (metis unfolding_complete unfolding_sound)
corollary unfolding_n_sound_complete: "∀rsg ∈ ran Γ ∪ {rs}. wf_chain Γ rsg ⟹ Γ,γ,p⊢ ⟨((process_call Γ)^^n) rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
proof(induction n arbitrary: rs)
case 0 thus ?case by simp
next
case (Suc n)
from Suc have "Γ,γ,p⊢ ⟨(process_call Γ ^^ n) rs, s⟩ ⇒ t = Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t" by blast
from Suc.prems have "∀a∈ran Γ ∪ {process_call Γ rs}. wf_chain Γ a"
proof(induction rs)
case Nil thus ?case by simp
next
case(Cons r rs)
from Cons.prems have "∀a∈ran Γ. wf_chain Γ a" by blast
from Cons.prems have "wf_chain Γ [r]"
apply(simp)
apply(clarify)
apply(simp add: wf_chain_def)
done
from Cons.prems have "wf_chain Γ rs"
apply(simp)
apply(clarify)
apply(simp add: wf_chain_def)
done
from this Cons.prems Cons.IH have "wf_chain Γ (process_call Γ rs)" by blast
from this ‹wf_chain Γ [r]›have "wf_chain Γ (r # (process_call Γ rs))" by(simp add: wf_chain_def)
from this Cons.prems have "wf_chain Γ (process_call Γ (r#rs))"
apply(cases r)
apply(rename_tac m a, clarify)
apply(case_tac a)
apply(simp_all)
apply(simp add: wf_chain_append)
apply(clarify)
apply(simp add: ‹wf_chain Γ (process_call Γ rs)›)
apply(rule wf_chain_add_match)
apply(rule wf_chain_process_ret)
apply(simp add: wf_chain_def)
apply(clarify)
by (metis ranI option.sel)
from this ‹∀a∈ran Γ. wf_chain Γ a› show ?case by simp
qed
from this Suc.IH[of "((process_call Γ) rs)"] have
"Γ,γ,p⊢ ⟨(process_call Γ ^^ n) (process_call Γ rs), s⟩ ⇒ t = Γ,γ,p⊢ ⟨process_call Γ rs, s⟩ ⇒ t"
by simp
from this show ?case by (simp add: Suc.prems funpow_swap1 unfolding_sound_complete)
qed
text_raw‹
\begin{verbatim}
loops in the linux kernel:
http://lxr.linux.no/linux+v3.2/net/ipv4/netfilter/ip_tables.c#L464
/* Figures out from what hook each rule can be called: returns 0 if
there are loops. Puts hook bitmask in comefrom. */
static int mark_source_chains(const struct xt_table_info *newinfo,
unsigned int valid_hooks, void *entry0)
discussion: http://marc.info/?l=netfilter-devel&m=105190848425334&w=2
\end{verbatim}
›
text‹Example›
lemma "process_call [''X'' ↦ [Rule (Match b) Return, Rule (Match c) Accept]] [Rule (Match a) (Call ''X'')] =
[Rule (MatchAnd (Match a) (MatchAnd (MatchNot (Match b)) (Match c))) Accept]" by (simp add: add_match_def)
text‹This is how a firewall processes a ruleset.
It starts at a certain chain, usually INPUT, FORWARD, or OUTPUT (called @{term chain_name} in the lemma).
The firewall has a default action of accept or drop.
We can check @{const sanity_wf_ruleset} and the other assumptions at runtime.
Consequently, we can apply @{const repeat_stabilize} as often as we want.
›
theorem repeat_stabilize_process_call:
assumes "sanity_wf_ruleset Γ" and "chain_name ∈ set (map fst Γ)" and "default_action = Accept ∨ default_action = Drop"
shows "(map_of Γ),γ,p⊢ ⟨repeat_stabilize n (process_call (map_of Γ)) [Rule MatchAny (Call chain_name), Rule MatchAny default_action], s⟩ ⇒ t ⟷
(map_of Γ),γ,p⊢ ⟨[Rule MatchAny (Call chain_name), Rule MatchAny default_action], s⟩ ⇒ t"
proof -
have x: "sanity_wf_ruleset Γ ⟹ rs ∈ ran (map_of Γ) ⟹ wf_chain (map_of Γ) rs" for Γ and rs::"'a rule list"
apply(simp add: sanity_wf_ruleset_def wf_chain_def)
by fastforce
from assms(1) have 1: "∀rsg ∈ ran (map_of Γ). wf_chain (map_of Γ) rsg"
apply(intro ballI)
apply(drule x, simp)
apply(simp)
done
let ?rs="[Rule MatchAny (Call chain_name), Rule MatchAny default_action]::'a rule list"
from assms(2,3) have 2: "wf_chain (map_of Γ) ?rs"
apply(simp add: wf_chain_def domD dom_map_of_conv_image_fst)
by blast
have "∀rsg ∈ ran Γ ∪ {rs}. wf_chain Γ rsg ⟹
Γ,γ,p⊢ ⟨repeat_stabilize n (process_call Γ) rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t" for Γ rs
by(simp add: repeat_stabilize_funpow unfolding_n_sound_complete)
moreover from 1 2 have "∀rsg ∈ ran (map_of Γ) ∪ {?rs}. wf_chain (map_of Γ) rsg" by simp
ultimately show ?thesis by simp
qed
definition unfold_optimize_ruleset_CHAIN
:: "('a match_expr ⇒ 'a match_expr) ⇒ string ⇒ action ⇒ 'a ruleset ⇒ 'a rule list option"
where
"unfold_optimize_ruleset_CHAIN optimize chain_name default_action rs = (let rs =
(repeat_stabilize 1000 (optimize_matches opt_MatchAny_match_expr)
(optimize_matches optimize
(rw_Reject (rm_LogEmpty (repeat_stabilize 10000 (process_call rs)
[Rule MatchAny (Call chain_name), Rule MatchAny default_action]
)))))
in if simple_ruleset rs then Some rs else None)"
lemma unfold_optimize_ruleset_CHAIN:
assumes "sanity_wf_ruleset Γ" and "chain_name ∈ set (map fst Γ)"
and "default_action = Accept ∨ default_action = Drop"
and "⋀m. matches γ (optimize m) p = matches γ m p"
and "unfold_optimize_ruleset_CHAIN optimize chain_name default_action (map_of Γ) = Some rs"
shows "(map_of Γ),γ,p⊢ ⟨rs, s⟩ ⇒ t ⟷
(map_of Γ),γ,p⊢ ⟨[Rule MatchAny (Call chain_name), Rule MatchAny default_action], s⟩ ⇒ t"
proof -
from assms(5) have rs: "rs = repeat_stabilize 1000 (optimize_matches opt_MatchAny_match_expr)
(optimize_matches optimize
(rw_Reject
(rm_LogEmpty
(repeat_stabilize 10000 (process_call (map_of Γ)) [Rule MatchAny (Call chain_name), Rule MatchAny default_action]))))"
by(simp add: unfold_optimize_ruleset_CHAIN_def Let_def split: if_split_asm)
have optimize_matches_generic_funpow_helper: "(⋀m. matches γ (f m) p = matches γ m p) ⟹
Γ,γ,p⊢ ⟨(optimize_matches f ^^ n) rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
for Γ f n rs
proof(induction n arbitrary:)
case 0 thus ?case by simp
next
case (Suc n) thus ?case
apply(simp)
apply(subst optimize_matches_generic[where P="λ_. True"])
by simp_all
qed
have "(map_of Γ),γ,p⊢ ⟨rs, s⟩ ⇒ t ⟷ map_of Γ,γ,p⊢ ⟨repeat_stabilize 10000 (process_call (map_of Γ))
[Rule MatchAny (Call chain_name), Rule MatchAny default_action], s⟩ ⇒ t"
apply(simp add: rs repeat_stabilize_funpow)
apply(subst optimize_matches_generic_funpow_helper)
apply (simp add: opt_MatchAny_match_expr_correct; fail)
apply(subst optimize_matches_generic[where P="λ_. True"], simp_all add: assms(4))
apply(simp add: iptables_bigstep_rw_Reject iptables_bigstep_rm_LogEmpty)
done
also have "… ⟷ (map_of Γ),γ,p⊢ ⟨[Rule MatchAny (Call chain_name), Rule MatchAny default_action], s⟩ ⇒ t"
using assms(1,2,3) by(intro repeat_stabilize_process_call[of Γ chain_name default_action γ p 10000 s t]) simp_all
finally show ?thesis .
qed
end
Theory Ternary
section‹Ternary Logic›
theory Ternary
imports Main
begin
text‹Kleene logic›
datatype ternaryvalue = TernaryTrue | TernaryFalse | TernaryUnknown
datatype ternaryformula = TernaryAnd ternaryformula ternaryformula
| TernaryOr ternaryformula ternaryformula
| TernaryNot ternaryformula
| TernaryValue ternaryvalue
fun ternary_to_bool :: "ternaryvalue ⇒ bool option" where
"ternary_to_bool TernaryTrue = Some True" |
"ternary_to_bool TernaryFalse = Some False" |
"ternary_to_bool TernaryUnknown = None"
fun bool_to_ternary :: "bool ⇒ ternaryvalue" where
"bool_to_ternary True = TernaryTrue" |
"bool_to_ternary False = TernaryFalse"
lemma "the ∘ ternary_to_bool ∘ bool_to_ternary = id"
by(simp add: fun_eq_iff, clarify, case_tac x, simp_all)
lemma ternary_to_bool_bool_to_ternary: "ternary_to_bool (bool_to_ternary X) = Some X"
by(cases X, simp_all)
lemma ternary_to_bool_None: "ternary_to_bool t = None ⟷ t = TernaryUnknown"
by(cases t, simp_all)
lemma ternary_to_bool_SomeE: "ternary_to_bool t = Some X ⟹
(t = TernaryTrue ⟹ X = True ⟹ P) ⟹ (t = TernaryFalse ⟹ X = False ⟹ P) ⟹ P"
by(cases t)(simp)+
lemma ternary_to_bool_Some: "ternary_to_bool t = Some X ⟷
(t = TernaryTrue ∧ X = True) ∨ (t = TernaryFalse ∧ X = False)"
by(cases t, simp_all)
lemma bool_to_ternary_Unknown: "bool_to_ternary t = TernaryUnknown ⟷ False"
by(cases t, simp_all)
fun eval_ternary_And :: "ternaryvalue ⇒ ternaryvalue ⇒ ternaryvalue" where
"eval_ternary_And TernaryTrue TernaryTrue = TernaryTrue" |
"eval_ternary_And TernaryTrue TernaryFalse = TernaryFalse" |
"eval_ternary_And TernaryFalse TernaryTrue = TernaryFalse" |
"eval_ternary_And TernaryFalse TernaryFalse = TernaryFalse" |
"eval_ternary_And TernaryFalse TernaryUnknown = TernaryFalse" |
"eval_ternary_And TernaryTrue TernaryUnknown = TernaryUnknown" |
"eval_ternary_And TernaryUnknown TernaryFalse = TernaryFalse" |
"eval_ternary_And TernaryUnknown TernaryTrue = TernaryUnknown" |
"eval_ternary_And TernaryUnknown TernaryUnknown = TernaryUnknown"
lemma eval_ternary_And_comm: "eval_ternary_And t1 t2 = eval_ternary_And t2 t1"
by (cases t1 t2 rule: ternaryvalue.exhaust[case_product ternaryvalue.exhaust]) auto
fun eval_ternary_Or :: "ternaryvalue ⇒ ternaryvalue ⇒ ternaryvalue" where
"eval_ternary_Or TernaryTrue TernaryTrue = TernaryTrue" |
"eval_ternary_Or TernaryTrue TernaryFalse = TernaryTrue" |
"eval_ternary_Or TernaryFalse TernaryTrue = TernaryTrue" |
"eval_ternary_Or TernaryFalse TernaryFalse = TernaryFalse" |
"eval_ternary_Or TernaryTrue TernaryUnknown = TernaryTrue" |
"eval_ternary_Or TernaryFalse TernaryUnknown = TernaryUnknown" |
"eval_ternary_Or TernaryUnknown TernaryTrue = TernaryTrue" |
"eval_ternary_Or TernaryUnknown TernaryFalse = TernaryUnknown" |
"eval_ternary_Or TernaryUnknown TernaryUnknown = TernaryUnknown"
fun eval_ternary_Not :: "ternaryvalue ⇒ ternaryvalue" where
"eval_ternary_Not TernaryTrue = TernaryFalse" |
"eval_ternary_Not TernaryFalse = TernaryTrue" |
"eval_ternary_Not TernaryUnknown = TernaryUnknown"
text‹Just to hint that we did not make a typo, we add the truth table for
the implication and show that it is compliant with @{term "a ⟶ b ⟷ ¬a ∨ b"}›
fun eval_ternary_Imp :: "ternaryvalue ⇒ ternaryvalue ⇒ ternaryvalue" where
"eval_ternary_Imp TernaryTrue TernaryTrue = TernaryTrue" |
"eval_ternary_Imp TernaryTrue TernaryFalse = TernaryFalse" |
"eval_ternary_Imp TernaryFalse TernaryTrue = TernaryTrue" |
"eval_ternary_Imp TernaryFalse TernaryFalse = TernaryTrue" |
"eval_ternary_Imp TernaryTrue TernaryUnknown = TernaryUnknown" |
"eval_ternary_Imp TernaryFalse TernaryUnknown = TernaryTrue" |
"eval_ternary_Imp TernaryUnknown TernaryTrue = TernaryTrue" |
"eval_ternary_Imp TernaryUnknown TernaryFalse = TernaryUnknown" |
"eval_ternary_Imp TernaryUnknown TernaryUnknown = TernaryUnknown"
lemma "eval_ternary_Imp a b = eval_ternary_Or (eval_ternary_Not a) b"
apply(cases a)
apply(case_tac [!] b)
apply(simp_all)
done
lemma eval_ternary_Not_UnknownD: "eval_ternary_Not t = TernaryUnknown ⟹ t = TernaryUnknown"
by (cases t) auto
lemma eval_ternary_DeMorgan:
"eval_ternary_Not (eval_ternary_And a b) = eval_ternary_Or (eval_ternary_Not a) (eval_ternary_Not b)"
"eval_ternary_Not (eval_ternary_Or a b) = eval_ternary_And (eval_ternary_Not a) (eval_ternary_Not b)"
by (cases a b rule: ternaryvalue.exhaust[case_product ternaryvalue.exhaust],auto)+
lemma eval_ternary_idempotence_Not: "eval_ternary_Not (eval_ternary_Not a) = a"
by (cases a) simp_all
lemma eval_ternary_simps_simple:
"eval_ternary_And TernaryTrue x = x"
"eval_ternary_And x TernaryTrue = x"
"eval_ternary_And TernaryFalse x = TernaryFalse"
"eval_ternary_And x TernaryFalse = TernaryFalse"
by(case_tac [!] x)(simp_all)
context
begin
private lemma bool_to_ternary_simp1: "bool_to_ternary X = TernaryTrue ⟷ X"
by (metis bool_to_ternary.elims ternaryvalue.distinct(1))
private lemma bool_to_ternary_simp2: "bool_to_ternary Y = TernaryFalse ⟷ ¬ Y"
by (metis bool_to_ternary.elims ternaryvalue.distinct(1))
private lemma bool_to_ternary_simp3: "eval_ternary_Not (bool_to_ternary X) = TernaryTrue ⟷ ¬ X"
by (metis (full_types) bool_to_ternary_simp2 eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
private lemma bool_to_ternary_simp4: "eval_ternary_Not (bool_to_ternary X) = TernaryFalse ⟷ X"
by (metis bool_to_ternary_simp1 eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
private lemma bool_to_ternary_simp5: "¬ (eval_ternary_Not (bool_to_ternary X) = TernaryUnknown)"
by (metis bool_to_ternary_Unknown eval_ternary_Not_UnknownD)
private lemma bool_to_ternary_simp6: "bool_to_ternary X ≠ TernaryUnknown"
by (metis (full_types) bool_to_ternary.simps(1) bool_to_ternary.simps(2) ternaryvalue.distinct(3) ternaryvalue.distinct(5))
lemmas bool_to_ternary_simps = bool_to_ternary_simp1 bool_to_ternary_simp2
bool_to_ternary_simp3 bool_to_ternary_simp4
bool_to_ternary_simp5 bool_to_ternary_simp6
end
context
begin
private lemma bool_to_ternary_pullup1:
"eval_ternary_Not (bool_to_ternary X) = bool_to_ternary (¬ X)"
by(cases X)(simp_all)
private lemma bool_to_ternary_pullup2:
"eval_ternary_And (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1 ∧ X2)"
by (metis bool_to_ternary_simps(1) bool_to_ternary_simps(2) eval_ternary_simps_simple(2) eval_ternary_simps_simple(4))
private lemma bool_to_ternary_pullup3:
"eval_ternary_Imp (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1 ⟶ X2)"
by (metis bool_to_ternary_simps(1) bool_to_ternary_simps(2) eval_ternary_Imp.simps(1)
eval_ternary_Imp.simps(2) eval_ternary_Imp.simps(3) eval_ternary_Imp.simps(4))
private lemma bool_to_ternary_pullup4:
"eval_ternary_Or (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1 ∨ X2)"
by (metis (full_types) bool_to_ternary.simps(1) bool_to_ternary.simps(2) eval_ternary_Or.simps(1) eval_ternary_Or.simps(2) eval_ternary_Or.simps(3) eval_ternary_Or.simps(4))
lemmas bool_to_ternary_pullup = bool_to_ternary_pullup1 bool_to_ternary_pullup2
bool_to_ternary_pullup3 bool_to_ternary_pullup4
end
fun ternary_ternary_eval :: "ternaryformula ⇒ ternaryvalue" where
"ternary_ternary_eval (TernaryAnd t1 t2) = eval_ternary_And (ternary_ternary_eval t1) (ternary_ternary_eval t2)" |
"ternary_ternary_eval (TernaryOr t1 t2) = eval_ternary_Or (ternary_ternary_eval t1) (ternary_ternary_eval t2)" |
"ternary_ternary_eval (TernaryNot t) = eval_ternary_Not (ternary_ternary_eval t)" |
"ternary_ternary_eval (TernaryValue t) = t"
lemma ternary_ternary_eval_DeMorgan: "ternary_ternary_eval (TernaryNot (TernaryAnd a b)) =
ternary_ternary_eval (TernaryOr (TernaryNot a) (TernaryNot b))"
by (simp add: eval_ternary_DeMorgan)
lemma ternary_ternary_eval_idempotence_Not:
"ternary_ternary_eval (TernaryNot (TernaryNot a)) = ternary_ternary_eval a"
by (simp add: eval_ternary_idempotence_Not)
lemma ternary_ternary_eval_TernaryAnd_comm:
"ternary_ternary_eval (TernaryAnd t1 t2) = ternary_ternary_eval (TernaryAnd t2 t1)"
by (simp add: eval_ternary_And_comm)
lemma "eval_ternary_Not (ternary_ternary_eval t) = (ternary_ternary_eval (TernaryNot t))" by simp
context
begin
private lemma eval_ternary_simps_2:
"eval_ternary_And (bool_to_ternary P) T = TernaryTrue ⟷ P ∧ T = TernaryTrue"
"eval_ternary_And T (bool_to_ternary P) = TernaryTrue ⟷ P ∧ T = TernaryTrue"
apply(case_tac [!] P)
apply(simp_all add: eval_ternary_simps_simple)
done
private lemma eval_ternary_simps_3:
"eval_ternary_And (ternary_ternary_eval x) T = TernaryTrue ⟷
ternary_ternary_eval x = TernaryTrue ∧ T = TernaryTrue"
"eval_ternary_And T (ternary_ternary_eval x) = TernaryTrue ⟷
ternary_ternary_eval x = TernaryTrue ∧ T = TernaryTrue"
apply(case_tac [!] T)
apply(simp_all add: eval_ternary_simps_simple)
apply(case_tac [!] "(ternary_ternary_eval x)")
apply(simp_all)
done
lemmas eval_ternary_simps = eval_ternary_simps_simple eval_ternary_simps_2 eval_ternary_simps_3
end
definition ternary_eval :: "ternaryformula ⇒ bool option" where
"ternary_eval t = ternary_to_bool (ternary_ternary_eval t)"
subsection‹Negation Normal Form›
text‹A formula is in Negation Normal Form (NNF) if negations only occur at the atoms (not before and/or)›
inductive NegationNormalForm :: "ternaryformula ⇒ bool" where
"NegationNormalForm (TernaryValue v)" |
"NegationNormalForm (TernaryNot (TernaryValue v))" |
"NegationNormalForm φ ⟹ NegationNormalForm ψ ⟹ NegationNormalForm (TernaryAnd φ ψ)"|
"NegationNormalForm φ ⟹ NegationNormalForm ψ ⟹ NegationNormalForm (TernaryOr φ ψ)"
text‹Convert a @{typ ternaryformula} to a @{typ ternaryformula} in NNF.›
fun NNF_ternary :: "ternaryformula ⇒ ternaryformula" where
"NNF_ternary (TernaryValue v) = TernaryValue v" |
"NNF_ternary (TernaryAnd t1 t2) = TernaryAnd (NNF_ternary t1) (NNF_ternary t2)" |
"NNF_ternary (TernaryOr t1 t2) = TernaryOr (NNF_ternary t1) (NNF_ternary t2)" |
"NNF_ternary (TernaryNot (TernaryNot t)) = NNF_ternary t" |
"NNF_ternary (TernaryNot (TernaryValue v)) = TernaryValue (eval_ternary_Not v)" |
"NNF_ternary (TernaryNot (TernaryAnd t1 t2)) = TernaryOr (NNF_ternary (TernaryNot t1)) (NNF_ternary (TernaryNot t2))" |
"NNF_ternary (TernaryNot (TernaryOr t1 t2)) = TernaryAnd (NNF_ternary (TernaryNot t1)) (NNF_ternary (TernaryNot t2))"
lemma NNF_ternary_correct: "ternary_ternary_eval (NNF_ternary t) = ternary_ternary_eval t"
proof(induction t rule: NNF_ternary.induct)
qed(simp_all add: eval_ternary_DeMorgan eval_ternary_idempotence_Not)
lemma NNF_ternary_NegationNormalForm: "NegationNormalForm (NNF_ternary t)"
proof(induction t rule: NNF_ternary.induct)
qed(auto simp add: eval_ternary_DeMorgan eval_ternary_idempotence_Not intro: NegationNormalForm.intros)
context
begin
private lemma ternary_lift1: "eval_ternary_Not tv ≠ TernaryFalse ⟷ tv = TernaryFalse ∨ tv = TernaryUnknown"
using eval_ternary_Not.elims by blast
private lemma ternary_lift2: "eval_ternary_Not tv ≠ TernaryTrue ⟷ tv = TernaryTrue ∨ tv = TernaryUnknown"
using eval_ternary_Not.elims by blast
private lemma ternary_lift3: "eval_ternary_Not tv = TernaryFalse ⟷ tv = TernaryTrue"
by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
private lemma ternary_lift4: "eval_ternary_Not tv = TernaryTrue ⟷ tv = TernaryFalse"
by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
private lemma ternary_lift5: "eval_ternary_Not tv = TernaryUnknown ⟷ tv = TernaryUnknown"
by (metis eval_ternary_Not.simps(3) eval_ternary_idempotence_Not)
private lemma ternary_lift6: "eval_ternary_And t1 t2 = TernaryFalse ⟷ t1 = TernaryFalse ∨ t2 = TernaryFalse"
using eval_ternary_And.elims by blast
private lemma ternary_lift7: "eval_ternary_And t1 t2 = TernaryTrue ⟷ t1 = TernaryTrue ∧ t2 = TernaryTrue"
using eval_ternary_And.elims by blast
lemmas ternary_lift = ternary_lift1 ternary_lift2 ternary_lift3 ternary_lift4 ternary_lift5 ternary_lift6 ternary_lift7
end
context
begin
private lemma l1: "eval_ternary_Not tv = TernaryTrue ⟹ tv = TernaryFalse"
by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
private lemma l2: "eval_ternary_And t1 t2 = TernaryFalse ⟹ t1 = TernaryFalse ∨ t2 = TernaryFalse"
using eval_ternary_And.elims by blast
lemmas eval_ternaryD = l1 l2
end
end
Theory Matching_Ternary
theory Matching_Ternary
imports "../Common/Ternary" "../Firewall_Common"
begin
section‹Packet Matching in Ternary Logic›
text‹The matcher for a primitive match expression @{typ "'a"}›
type_synonym ('a, 'packet) exact_match_tac="'a ⇒ 'packet ⇒ ternaryvalue"
text‹
If the matching is @{const TernaryUnknown}, it can be decided by the action whether this rule matches.
E.g. in doubt, we allow packets
›
type_synonym 'packet unknown_match_tac="action ⇒ 'packet ⇒ bool"
type_synonym ('a, 'packet) match_tac="(('a, 'packet) exact_match_tac × 'packet unknown_match_tac)"
text‹
For a given packet, map a firewall @{typ "'a match_expr"} to a @{typ ternaryformula}
Evaluating the formula gives whether the packet/rule matches (or unknown).
›
fun map_match_tac :: "('a, 'packet) exact_match_tac ⇒ 'packet ⇒ 'a match_expr ⇒ ternaryformula" where
"map_match_tac β p (MatchAnd m1 m2) = TernaryAnd (map_match_tac β p m1) (map_match_tac β p m2)" |
"map_match_tac β p (MatchNot m) = TernaryNot (map_match_tac β p m)" |
"map_match_tac β p (Match m) = TernaryValue (β m p)" |
"map_match_tac _ _ MatchAny = TernaryValue TernaryTrue"
context
begin
text‹the @{term ternaryformula}s we construct never have Or expressions.›
private fun ternary_has_or :: "ternaryformula ⇒ bool" where
"ternary_has_or (TernaryOr _ _) ⟷ True" |
"ternary_has_or (TernaryAnd t1 t2) ⟷ ternary_has_or t1 ∨ ternary_has_or t2" |
"ternary_has_or (TernaryNot t) ⟷ ternary_has_or t" |
"ternary_has_or (TernaryValue _) ⟷ False"
private lemma map_match_tac__does_not_use_TernaryOr: "¬ (ternary_has_or (map_match_tac β p m))"
by(induction m, simp_all)
declare ternary_has_or.simps[simp del]
end
fun ternary_to_bool_unknown_match_tac :: "'packet unknown_match_tac ⇒ action ⇒ 'packet ⇒ ternaryvalue ⇒ bool" where
"ternary_to_bool_unknown_match_tac _ _ _ TernaryTrue = True" |
"ternary_to_bool_unknown_match_tac _ _ _ TernaryFalse = False" |
"ternary_to_bool_unknown_match_tac α a p TernaryUnknown = α a p"
text‹
Matching a packet and a rule:
\begin{enumerate}
\item Translate @{typ "'a match_expr"} to ternary formula
\item Evaluate this formula
\item If @{const TernaryTrue}/@{const TernaryFalse}, return this value
\item If @{const TernaryUnknown}, apply the @{typ "'a unknown_match_tac"} to get a Boolean result
\end{enumerate}
›
definition matches :: "('a, 'packet) match_tac ⇒ 'a match_expr ⇒ action ⇒ 'packet ⇒ bool" where
"matches γ m a p ≡ ternary_to_bool_unknown_match_tac (snd γ) a p (ternary_ternary_eval (map_match_tac (fst γ) p m))"
text‹Alternative matches definitions, some more or less convenient›
lemma matches_tuple: "matches (β, α) m a p = ternary_to_bool_unknown_match_tac α a p (ternary_ternary_eval (map_match_tac β p m))"
unfolding matches_def by simp
lemma matches_case: "matches γ m a p ⟷ (case ternary_eval (map_match_tac (fst γ) p m) of None ⇒ (snd γ) a p | Some b ⇒ b)"
unfolding matches_def ternary_eval_def
by (cases "(ternary_ternary_eval (map_match_tac (fst γ) p m))") auto
lemma matches_case_tuple: "matches (β, α) m a p ⟷ (case ternary_eval (map_match_tac β p m) of None ⇒ α a p | Some b ⇒ b)"
by (auto simp: matches_case split: option.splits)
lemma matches_case_ternaryvalue_tuple: "matches (β, α) m a p ⟷ (case ternary_ternary_eval (map_match_tac β p m) of
TernaryUnknown ⇒ α a p |
TernaryTrue ⇒ True |
TernaryFalse ⇒ False)"
by(simp split: option.split ternaryvalue.split add: matches_case ternary_to_bool_None ternary_eval_def)
lemma matches_casesE:
"matches (β, α) m a p ⟹
(ternary_ternary_eval (map_match_tac β p m) = TernaryUnknown ⟹ α a p ⟹ P) ⟹
(ternary_ternary_eval (map_match_tac β p m) = TernaryTrue ⟹ P)
⟹ P"
proof(induction m)
qed(auto split: option.split_asm simp: matches_case_tuple ternary_eval_def ternary_to_bool_bool_to_ternary elim: ternary_to_bool.elims)
text‹
Example: ‹¬ Unknown› is as good as ‹Unknown›
›
lemma "⟦ ternary_ternary_eval (map_match_tac β p expr) = TernaryUnknown ⟧ ⟹ matches (β, α) expr a p ⟷ matches (β, α) (MatchNot expr) a p"
by(simp add: matches_case_ternaryvalue_tuple)
lemma bunch_of_lemmata_about_matches:
"matches γ (MatchAnd m1 m2) a p ⟷ matches γ m1 a p ∧ matches γ m2 a p"
"matches γ MatchAny a p"
"matches γ (MatchNot MatchAny) a p ⟷ False"
"matches γ (MatchNot (MatchNot m)) a p ⟷ matches γ m a p"
proof(case_tac [!] γ)
qed (simp_all split: ternaryvalue.split add: matches_case_ternaryvalue_tuple)
lemma match_raw_bool:
"matches (β, α) (Match expr) a p = (case ternary_to_bool (β expr p) of Some r ⇒ r | None ⇒ (α a p))"
by(simp_all split: ternaryvalue.split add: matches_case_ternaryvalue_tuple)
lemma match_raw_ternary:
"matches (β, α) (Match expr) a p = (case (β expr p) of TernaryTrue ⇒ True | TernaryFalse ⇒ False | TernaryUnknown ⇒ (α a p))"
by(simp_all split: ternaryvalue.split add: matches_case_ternaryvalue_tuple)
lemma matches_DeMorgan: "matches γ (MatchNot (MatchAnd m1 m2)) a p ⟷ (matches γ (MatchNot m1) a p) ∨ (matches γ (MatchNot m2) a p)"
by (cases γ) (simp split: ternaryvalue.split add: matches_case_ternaryvalue_tuple eval_ternary_DeMorgan)
subsection‹Ternary Matcher Algebra›
lemma matches_and_comm: "matches γ (MatchAnd m m') a p ⟷ matches γ (MatchAnd m' m) a p"
apply(cases γ, rename_tac β α, clarify)
by(simp add: matches_case_ternaryvalue_tuple eval_ternary_And_comm)
lemma matches_not_idem: "matches γ (MatchNot (MatchNot m)) a p ⟷ matches γ m a p"
by (fact bunch_of_lemmata_about_matches)
lemma MatchOr: "matches γ (MatchOr m1 m2) a p ⟷ matches γ m1 a p ∨ matches γ m2 a p"
by(simp add: MatchOr_def matches_DeMorgan matches_not_idem)
lemma MatchOr_MatchNot: "matches γ (MatchNot (MatchOr m1 m2)) a p ⟷ matches γ (MatchNot m1) a p ∧ matches γ (MatchNot m2) a p"
by(simp add: MatchOr_def matches_DeMorgan bunch_of_lemmata_about_matches)
lemma "(TernaryNot (map_match_tac β p (m))) = (map_match_tac β p (MatchNot m))"
by (metis map_match_tac.simps(2))
context
begin
private lemma matches_simp1: "matches γ m a p ⟹ matches γ (MatchAnd m m') a p ⟷ matches γ m' a p"
apply(cases γ, rename_tac β α, clarify)
apply(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple)
done
private lemma matches_simp11: "matches γ m a p ⟹ matches γ (MatchAnd m' m) a p ⟷ matches γ m' a p"
by(simp_all add: matches_and_comm matches_simp1)
private lemma matches_simp2: "matches γ (MatchAnd m m') a p ⟹ ¬ matches γ m a p ⟹ False"
by (simp add: bunch_of_lemmata_about_matches)
private lemma matches_simp22: "matches γ (MatchAnd m m') a p ⟹ ¬ matches γ m' a p ⟹ False"
by (simp add: bunch_of_lemmata_about_matches)
private lemma matches_simp3: "matches γ (MatchNot m) a p ⟹ matches γ m a p ⟹ (snd γ) a p"
apply(cases γ, rename_tac β α, clarify)
apply(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple)
done
private lemma "matches γ (MatchNot m) a p ⟹ matches γ m a p ⟹ (ternary_eval (map_match_tac (fst γ) p m)) = None"
apply(cases γ, rename_tac β α, clarify)
apply(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple ternary_eval_def)
done
lemmas matches_simps = matches_simp1 matches_simp11
lemmas matches_dest = matches_simp2 matches_simp22
end
lemma matches_iff_apply_f_generic: "ternary_ternary_eval (map_match_tac β p (f (β,α) a m)) = ternary_ternary_eval (map_match_tac β p m) ⟹ matches (β,α) (f (β,α) a m) a p ⟷ matches (β,α) m a p"
by(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple)
lemma matches_iff_apply_f: "ternary_ternary_eval (map_match_tac β p (f m)) = ternary_ternary_eval (map_match_tac β p m) ⟹ matches (β,α) (f m) a p ⟷ matches (β,α) m a p"
by(fact matches_iff_apply_f_generic)
lemma opt_MatchAny_match_expr_correct: "matches γ (opt_MatchAny_match_expr m) = matches γ m"
proof(case_tac γ, rename_tac β α, clarify)
fix β α
assume "γ = (β, α)"
have "ternary_ternary_eval (map_match_tac β p (opt_MatchAny_match_expr_once m)) =
ternary_ternary_eval (map_match_tac β p m)" for p m
proof(induction m rule: opt_MatchAny_match_expr_once.induct)
qed(simp_all add: eval_ternary_simps eval_ternary_idempotence_Not)
thus "matches (β, α) (opt_MatchAny_match_expr m) = matches (β, α) m"
apply(simp add: fun_eq_iff)
apply(clarify, rename_tac a p)
apply(rule_tac f="opt_MatchAny_match_expr" in matches_iff_apply_f)
apply(simp)
apply(simp add: opt_MatchAny_match_expr_def)
apply(rule repeat_stabilize_induct)
by(simp)+
qed
text‹An @{typ "'p unknown_match_tac"} is wf if it behaves equal for @{const Reject} and @{const Drop}›
definition wf_unknown_match_tac :: "'p unknown_match_tac ⇒ bool" where
"wf_unknown_match_tac α ≡ (α Drop = α Reject)"
lemma wf_unknown_match_tacD_False1: "wf_unknown_match_tac α ⟹ ¬ matches (β, α) m Reject p ⟹ matches (β, α) m Drop p ⟹ False"
unfolding wf_unknown_match_tac_def by(simp add: matches_case_ternaryvalue_tuple split: ternaryvalue.split_asm)
lemma wf_unknown_match_tacD_False2: "wf_unknown_match_tac α ⟹ matches (β, α) m Reject p ⟹ ¬ matches (β, α) m Drop p ⟹ False"
unfolding wf_unknown_match_tac_def by(simp add: matches_case_ternaryvalue_tuple split: ternaryvalue.split_asm)
subsection‹Removing Unknown Primitives›
definition unknown_match_all :: "'a unknown_match_tac ⇒ action ⇒ bool" where
"unknown_match_all α a = (∀p. α a p)"
definition unknown_not_match_any :: "'a unknown_match_tac ⇒ action ⇒ bool" where
"unknown_not_match_any α a = (∀p. ¬ α a p)"
fun remove_unknowns_generic :: "('a, 'packet) match_tac ⇒ action ⇒ 'a match_expr ⇒ 'a match_expr" where
"remove_unknowns_generic _ _ MatchAny = MatchAny" |
"remove_unknowns_generic _ _ (MatchNot MatchAny) = MatchNot MatchAny" |
"remove_unknowns_generic (β, α) a (Match A) = (if
(∀p. ternary_ternary_eval (map_match_tac β p (Match A)) = TernaryUnknown)
then
if unknown_match_all α a then MatchAny else if unknown_not_match_any α a then MatchNot MatchAny else Match A
else (Match A))" |
"remove_unknowns_generic (β, α) a (MatchNot (Match A)) = (if
(∀p. ternary_ternary_eval (map_match_tac β p (Match A)) = TernaryUnknown)
then
if unknown_match_all α a then MatchAny else if unknown_not_match_any α a then MatchNot MatchAny else MatchNot (Match A)
else MatchNot (Match A))" |
"remove_unknowns_generic (β, α) a (MatchNot (MatchNot m)) = remove_unknowns_generic (β, α) a m" |
"remove_unknowns_generic (β, α) a (MatchAnd m1 m2) = MatchAnd
(remove_unknowns_generic (β, α) a m1)
(remove_unknowns_generic (β, α) a m2)" |
"remove_unknowns_generic (β, α) a (MatchNot (MatchAnd m1 m2)) =
(if (remove_unknowns_generic (β, α) a (MatchNot m1)) = MatchAny ∨
(remove_unknowns_generic (β, α) a (MatchNot m2)) = MatchAny
then MatchAny else
(if (remove_unknowns_generic (β, α) a (MatchNot m1)) = MatchNot MatchAny then
remove_unknowns_generic (β, α) a (MatchNot m2) else
if (remove_unknowns_generic (β, α) a (MatchNot m2)) = MatchNot MatchAny then
remove_unknowns_generic (β, α) a (MatchNot m1) else
MatchNot (MatchAnd (MatchNot (remove_unknowns_generic (β, α) a (MatchNot m1))) (MatchNot (remove_unknowns_generic (β, α) a (MatchNot m2)))))
)"
lemma[code_unfold]: "remove_unknowns_generic γ a (MatchNot (MatchAnd m1 m2)) =
(let m1' = remove_unknowns_generic γ a (MatchNot m1); m2' = remove_unknowns_generic γ a (MatchNot m2) in
(if m1' = MatchAny ∨ m2' = MatchAny
then MatchAny
else
if m1' = MatchNot MatchAny then m2' else
if m2' = MatchNot MatchAny then m1'
else
MatchNot (MatchAnd (MatchNot m1') (MatchNot m2')))
)"
by(cases γ)(simp)
lemma remove_unknowns_generic_simp_3_4_unfolded: "remove_unknowns_generic (β, α) a (Match A) = (if
(∀p. ternary_ternary_eval (map_match_tac β p (Match A)) = TernaryUnknown)
then
if (∀p. α a p) then MatchAny else if (∀p. ¬ α a p) then MatchNot MatchAny else Match A
else (Match A))"
"remove_unknowns_generic (β, α) a (MatchNot (Match A)) = (if
(∀p. ternary_ternary_eval (map_match_tac β p (Match A)) = TernaryUnknown)
then
if (∀p. α a p) then MatchAny else if (∀p. ¬ α a p) then MatchNot MatchAny else MatchNot (Match A)
else MatchNot (Match A))"
by(auto simp add: unknown_match_all_def unknown_not_match_any_def)
declare remove_unknowns_generic.simps[simp del]
lemmas remove_unknowns_generic_simps2 = remove_unknowns_generic.simps(1) remove_unknowns_generic.simps(2)
remove_unknowns_generic_simp_3_4_unfolded
remove_unknowns_generic.simps(5) remove_unknowns_generic.simps(6) remove_unknowns_generic.simps(7)
lemma "matches (β, α) (remove_unknowns_generic (β, α) a (MatchNot (Match A))) a p = matches (β, α) (MatchNot (Match A)) a p"
by(simp add: remove_unknowns_generic_simps2 matches_case_ternaryvalue_tuple)
lemma remove_unknowns_generic: "matches γ (remove_unknowns_generic γ a m) a = matches γ m a"
proof -
have "matches γ (remove_unknowns_generic γ a m) a p = matches γ m a p"
for p
proof(induction γ a m rule: remove_unknowns_generic.induct)
case 3 thus ?case
by(simp add: bunch_of_lemmata_about_matches match_raw_ternary remove_unknowns_generic_simps2)
next
case 4 thus ?case
by(simp add: matches_case_ternaryvalue_tuple remove_unknowns_generic_simps2)
next
case 7 thus ?case
apply(simp add: bunch_of_lemmata_about_matches matches_DeMorgan remove_unknowns_generic_simps2)
apply(simp add: matches_case_ternaryvalue_tuple)
by fastforce
qed(simp_all add: bunch_of_lemmata_about_matches remove_unknowns_generic_simps2)
thus ?thesis by(simp add: fun_eq_iff)
qed
fun has_unknowns :: " ('a, 'p) exact_match_tac ⇒ 'a match_expr ⇒ bool" where
"has_unknowns β (Match A) = (∃p. ternary_ternary_eval (map_match_tac β p (Match A)) = TernaryUnknown)" |
"has_unknowns β (MatchNot m) = has_unknowns β m" |
"has_unknowns β MatchAny = False" |
"has_unknowns β (MatchAnd m1 m2) = (has_unknowns β m1 ∨ has_unknowns β m2)"
definition packet_independent_α :: "'p unknown_match_tac ⇒ bool" where
"packet_independent_α α = (∀a p1 p2. a = Accept ∨ a = Drop ⟶ α a p1 ⟷ α a p2)"
lemma packet_independent_unknown_match: "a = Accept ∨ a = Drop ⟹ packet_independent_α α ⟹ ¬ unknown_not_match_any α a ⟷ unknown_match_all α a"
by(auto simp add: packet_independent_α_def unknown_match_all_def unknown_not_match_any_def)
text‹If for some type the exact matcher returns unknown, then it returns unknown for all these types›
definition packet_independent_β_unknown :: "('a, 'packet) exact_match_tac ⇒ bool" where
"packet_independent_β_unknown β ≡ ∀A. (∃p. β A p ≠ TernaryUnknown) ⟶ (∀p. β A p ≠ TernaryUnknown)"
lemma remove_unknowns_generic_specification: "a = Accept ∨ a = Drop ⟹ packet_independent_α α ⟹
packet_independent_β_unknown β ⟹
¬ has_unknowns β (remove_unknowns_generic (β, α) a m)"
proof(induction "(β, α)" a m rule: remove_unknowns_generic.induct)
case 3 thus ?case by(simp add: packet_independent_unknown_match packet_independent_β_unknown_def remove_unknowns_generic.simps)
next
case 4 thus ?case by(simp add: packet_independent_unknown_match packet_independent_β_unknown_def remove_unknowns_generic.simps)
qed(simp_all add: remove_unknowns_generic.simps)
text‹Checking is something matches unconditionally›
context
begin
private lemma no_primitives_no_unknown: "¬ has_primitive m ⟹ (ternary_ternary_eval (map_match_tac β p m)) ≠ TernaryUnknown"
proof(induction m)
case Match thus ?case by auto
next
case MatchAny thus ?case by simp
next
case MatchAnd thus ?case by(auto elim: eval_ternary_And.elims)
next
case MatchNot thus ?case by(auto dest: eval_ternary_Not_UnknownD)
qed
private lemma no_primitives_matchNot: assumes "¬ has_primitive m" shows "matches γ (MatchNot m) a p ⟷ ¬ matches γ m a p"
proof -
obtain β α where "(β, α) = γ" by (cases γ, simp)
thm no_primitives_no_unknown
from assms have "matches (β, α) (MatchNot m) a p ⟷ ¬ matches (β, α) m a p"
apply(induction m)
apply(simp_all add: matches_case_ternaryvalue_tuple split: ternaryvalue.split )
apply(rename_tac m1 m2)
by(simp split: ternaryvalue.split_asm)
with ‹(β, α) = γ› assms show ?thesis by simp
qed
lemma matcheq_matchAny: "¬ has_primitive m ⟹ matcheq_matchAny m ⟷ matches γ m a p"
proof(induction m)
case Match hence False by auto
thus ?case ..
next
case (MatchNot m)
from MatchNot.prems have "¬ has_primitive m" by simp
with no_primitives_matchNot have "matches γ (MatchNot m) a p = (¬ matches γ m a p)" by metis
with MatchNot show ?case by(simp)
next
case (MatchAnd m1 m2)
thus ?case by(simp add: bunch_of_lemmata_about_matches)
next
case MatchAny show ?case by(simp add: Matching_Ternary.bunch_of_lemmata_about_matches)
qed
lemma matcheq_matchNone: "¬ has_primitive m ⟹ matcheq_matchNone m ⟷ ¬ matches γ m a p"
by(auto dest: matcheq_matchAny matachAny_matchNone)
lemma matcheq_matchNone_not_matches: "matcheq_matchNone m ⟹ ¬ matches γ m a p"
proof(induction m rule: matcheq_matchNone.induct)
qed(auto simp add: bunch_of_lemmata_about_matches matches_DeMorgan)
end
text‹Lemmas about @{const MatchNot} in ternary logic.›
lemma matches_MatchNot_no_unknowns:
assumes "¬ has_unknowns β m"
shows "matches (β,α) (MatchNot m) a p ⟷ ¬ matches (β,α) m a p"
proof -
{ fix m have "¬ has_unknowns β m ⟹
ternary_to_bool (ternary_ternary_eval (map_match_tac β p m)) ≠ None"
apply(induction m)
apply(simp_all)
using ternary_to_bool.elims apply blast
using ternary_to_bool_Some apply fastforce
using ternary_lift(6) ternary_to_bool_Some by auto
} note no_unknowns_ternary_to_bool_Some=this
from assms show ?thesis
by(auto split: option.split_asm
simp: matches_case_tuple no_unknowns_ternary_to_bool_Some ternary_to_bool_Some ternary_eval_def ternary_to_bool_bool_to_ternary
elim: ternary_to_bool.elims)
qed
lemma MatchNot_ternary_ternary_eval: "(ternary_ternary_eval (map_match_tac β p m')) = (ternary_ternary_eval (map_match_tac β p m)) ⟹
matches (β,α) (MatchNot m') a p = matches (β,α) (MatchNot m) a p"
by(simp add: matches_tuple)
text‹For our @{typ "'p unknown_match_tac"}s ‹in_doubt_allow› and ‹in_doubt_deny›,
when doing an induction over some function that modifies @{term "m::'a match_expr"},
we get the @{const MatchNot} case for free (if we can set arbitrary @{term "p::'p"}).
This does not hold for arbitrary @{typ "'p unknown_match_tac"}s.›
lemma matches_induction_case_MatchNot:
assumes "α Drop ≠ α Accept" and "packet_independent_α α"
and "∀ a. matches (β,α) m' a p = matches (β,α) m a p"
shows "matches (β,α) (MatchNot m') a p = matches (β,α) (MatchNot m) a p"
proof -
from assms(1) assms(2) have xxxx_xxX: "⋀b. ∀a. α a p = (¬ b) ⟹ False"
apply(simp add: packet_independent_α_def)
apply(case_tac "α Accept p")
apply(simp_all)
apply(case_tac [!] "α Drop p")
apply(simp_all add: fun_eq_iff)
apply blast+
done
have xx2: "⋀t. ternary_eval (TernaryNot t) = None ⟹ ternary_eval t = None"
by (simp add: eval_ternary_Not_UnknownD ternary_eval_def ternary_to_bool_None)
have xx3: "⋀t b. ternary_eval (TernaryNot t) = Some b ⟹ ternary_eval t = Some (¬ b)"
by (metis eval_ternary_Not.simps(1) eval_ternary_Not.simps(2) ternary_eval_def ternary_ternary_eval.simps(3) ternary_ternary_eval_idempotence_Not ternary_to_bool_Some)
from assms show ?thesis
apply(simp add: matches_case_tuple)
apply(case_tac "ternary_eval (TernaryNot (map_match_tac β p m'))")
apply(case_tac [!] "ternary_eval (TernaryNot (map_match_tac β p m))")
apply(simp_all)
apply(drule xx2)
apply(drule xx3)
apply(simp)
using xxxx_xxX apply metis
apply(drule xx2)
apply(drule xx3)
apply(simp)
using xxxx_xxX apply metis
apply(drule xx3)+
apply(simp)
done
qed
end
Theory Semantics_Ternary
theory Semantics_Ternary
imports Matching_Ternary "../Common/List_Misc"
begin
section‹Embedded Ternary-Matching Big Step Semantics›
subsection‹Ternary Semantics (Big Step)›
inductive approximating_bigstep :: "('a, 'p) match_tac ⇒ 'p ⇒ 'a rule list ⇒ state ⇒ state ⇒ bool"
("_,_⊢ ⟨_, _⟩ ⇒⇩α _" [60,60,20,98,98] 89)
for γ and p where
skip: "γ,p⊢ ⟨[], t⟩ ⇒⇩α t" |
accept: "⟦matches γ m Accept p⟧ ⟹ γ,p⊢ ⟨[Rule m Accept], Undecided⟩ ⇒⇩α Decision FinalAllow" |
drop: "⟦matches γ m Drop p⟧ ⟹ γ,p⊢ ⟨[Rule m Drop], Undecided⟩ ⇒⇩α Decision FinalDeny" |
reject: "⟦matches γ m Reject p⟧ ⟹ γ,p⊢ ⟨[Rule m Reject], Undecided⟩ ⇒⇩α Decision FinalDeny" |
log: "⟦matches γ m Log p⟧ ⟹ γ,p⊢ ⟨[Rule m Log], Undecided⟩ ⇒⇩α Undecided" |
empty: "⟦matches γ m Empty p⟧ ⟹ γ,p⊢ ⟨[Rule m Empty], Undecided⟩ ⇒⇩α Undecided" |
nomatch: "⟦¬ matches γ m a p⟧ ⟹ γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒⇩α Undecided" |
decision: "γ,p⊢ ⟨rs, Decision X⟩ ⇒⇩α Decision X" |
seq: "⟦γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒⇩α t; γ,p⊢ ⟨rs⇩2, t⟩ ⇒⇩α t'⟧ ⟹ γ,p⊢ ⟨rs⇩1@rs⇩2, Undecided⟩ ⇒⇩α t'"
thm approximating_bigstep.induct[of γ p rs s t P]
lemma approximating_bigstep_induct[case_names Skip Allow Deny Log Nomatch Decision Seq, induct pred: approximating_bigstep] : "γ,p⊢ ⟨rs,s⟩ ⇒⇩α t ⟹
(⋀t. P [] t t) ⟹
(⋀m a. matches γ m a p ⟹ a = Accept ⟹ P [Rule m a] Undecided (Decision FinalAllow)) ⟹
(⋀m a. matches γ m a p ⟹ a = Drop ∨ a = Reject ⟹ P [Rule m a] Undecided (Decision FinalDeny)) ⟹
(⋀m a. matches γ m a p ⟹ a = Log ∨ a = Empty ⟹ P [Rule m a] Undecided Undecided) ⟹
(⋀m a. ¬ matches γ m a p ⟹ P [Rule m a] Undecided Undecided) ⟹
(⋀rs X. P rs (Decision X) (Decision X)) ⟹
(⋀rs rs⇩1 rs⇩2 t t'. rs = rs⇩1 @ rs⇩2 ⟹ γ,p⊢ ⟨rs⇩1,Undecided⟩ ⇒⇩α t ⟹ P rs⇩1 Undecided t ⟹ γ,p⊢ ⟨rs⇩2,t⟩ ⇒⇩α t' ⟹ P rs⇩2 t t' ⟹ P rs Undecided t')
⟹ P rs s t"
by (induction rule: approximating_bigstep.induct) (simp_all)
lemma skipD: "γ,p⊢ ⟨[], s⟩ ⇒⇩α t ⟹ s = t"
by (induction "[]::'a rule list" s t rule: approximating_bigstep_induct) (simp_all)
lemma decisionD: "γ,p⊢ ⟨rs, Decision X⟩ ⇒⇩α t ⟹ t = Decision X"
by (induction rs "Decision X" t rule: approximating_bigstep_induct) (simp_all)
lemma acceptD: "γ,p⊢ ⟨[Rule m Accept], Undecided⟩ ⇒⇩α t ⟹ matches γ m Accept p ⟹ t = Decision FinalAllow"
proof (induction "[Rule m Accept]" Undecided t rule: approximating_bigstep_induct)
case Seq thus ?case by (metis list_app_singletonE skipD)
qed(simp_all)
lemma dropD: "γ,p⊢ ⟨[Rule m Drop], Undecided⟩ ⇒⇩α t ⟹ matches γ m Drop p ⟹ t = Decision FinalDeny"
apply (induction "[Rule m Drop]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)
lemma rejectD: "γ,p⊢ ⟨[Rule m Reject], Undecided⟩ ⇒⇩α t ⟹ matches γ m Reject p ⟹ t = Decision FinalDeny"
apply (induction "[Rule m Reject]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)
lemma logD: "γ,p⊢ ⟨[Rule m Log], Undecided⟩ ⇒⇩α t ⟹ t = Undecided"
apply (induction "[Rule m Log]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)
lemma emptyD: "γ,p⊢ ⟨[Rule m Empty], Undecided⟩ ⇒⇩α t ⟹ t = Undecided"
apply (induction "[Rule m Empty]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)
lemma nomatchD: "γ,p⊢ ⟨[Rule m a], Undecided⟩ ⇒⇩α t ⟹ ¬ matches γ m a p ⟹ t = Undecided"
apply (induction "[Rule m a]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)
lemmas approximating_bigstepD = skipD acceptD dropD rejectD logD emptyD nomatchD decisionD
lemma approximating_bigstep_to_undecided: "γ,p⊢ ⟨rs, s⟩ ⇒⇩α Undecided ⟹ s = Undecided"
by (metis decisionD state.exhaust)
lemma approximating_bigstep_to_decision1: "γ,p⊢ ⟨rs, Decision Y⟩ ⇒⇩α Decision X ⟹ Y = X"
by (metis decisionD state.inject)
lemma nomatch_fst: "¬ matches γ m a p ⟹ γ,p⊢ ⟨rs, s⟩ ⇒⇩α t ⟹ γ,p⊢ ⟨Rule m a # rs, s⟩ ⇒⇩α t"
apply(cases s)
apply(clarify)
apply(drule nomatch)
apply(drule(1) seq)
apply (simp; fail)
apply(clarify)
apply(drule decisionD)
apply(clarify)
apply(simp add: decision)
done
lemma seq':
assumes "rs = rs⇩1 @ rs⇩2" "γ,p⊢ ⟨rs⇩1,s⟩ ⇒⇩α t" "γ,p⊢ ⟨rs⇩2,t⟩ ⇒⇩α t'"
shows "γ,p⊢ ⟨rs,s⟩ ⇒⇩α t'"
using assms by (cases s) (auto intro: seq decision dest: decisionD)
lemma seq_split:
assumes "γ,p⊢ ⟨rs, s⟩ ⇒⇩α t" "rs = rs⇩1@rs⇩2"
obtains t' where "γ,p⊢ ⟨rs⇩1,s⟩ ⇒⇩α t'" "γ,p⊢ ⟨rs⇩2,t'⟩ ⇒⇩α t"
using assms
proof (induction rs s t arbitrary: rs⇩1 rs⇩2 thesis rule: approximating_bigstep_induct)
case Allow thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
next
case Deny thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
next
case Log thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
next
case Nomatch thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
next
case (Seq rs rsa rsb t t')
hence rs: "rsa @ rsb = rs⇩1 @ rs⇩2" by simp
note List.append_eq_append_conv_if[simp]
from rs show ?case
proof (cases rule: list_app_eq_cases)
case longer
with Seq have t1: "γ,p⊢ ⟨take (length rsa) rs⇩1, Undecided⟩ ⇒⇩α t"
by simp
from Seq longer obtain t2
where t2a: "γ,p⊢ ⟨drop (length rsa) rs⇩1,t⟩ ⇒⇩α t2"
and rs2_t2: "γ,p⊢ ⟨rs⇩2,t2⟩ ⇒⇩α t'"
by blast
with t1 rs2_t2 have "γ,p⊢ ⟨take (length rsa) rs⇩1 @ drop (length rsa) rs⇩1,Undecided⟩ ⇒⇩α t2"
by (blast intro: approximating_bigstep.seq)
with Seq rs2_t2 show ?thesis
by simp
next
case shorter
with rs have rsa': "rsa = rs⇩1 @ take (length rsa - length rs⇩1) rs⇩2"
by (metis append_eq_conv_conj length_drop)
from shorter rs have rsb': "rsb = drop (length rsa - length rs⇩1) rs⇩2"
by (metis append_eq_conv_conj length_drop)
from Seq rsa' obtain t1
where t1a: "γ,p⊢ ⟨rs⇩1,Undecided⟩ ⇒⇩α t1"
and t1b: "γ,p⊢ ⟨take (length rsa - length rs⇩1) rs⇩2,t1⟩ ⇒⇩α t"
by blast
from rsb' Seq.hyps have t2: "γ,p⊢ ⟨drop (length rsa - length rs⇩1) rs⇩2,t⟩ ⇒⇩α t'"
by blast
with seq' t1b have "γ,p⊢ ⟨rs⇩2,t1⟩ ⇒⇩α t'" by (metis append_take_drop_id)
with Seq t1a show ?thesis
by fast
qed
qed (auto intro: approximating_bigstep.intros)
lemma seqE_fst:
assumes "γ,p⊢ ⟨r#rs, s⟩ ⇒⇩α t"
obtains t' where "γ,p⊢ ⟨[r],s⟩ ⇒⇩α t'" "γ,p⊢ ⟨rs,t'⟩ ⇒⇩α t"
using assms seq_split by (metis append_Cons append_Nil)
lemma seq_fst: assumes "γ,p⊢ ⟨[r], s⟩ ⇒⇩α t" and "γ,p⊢ ⟨rs, t⟩ ⇒⇩α t'" shows "γ,p⊢ ⟨r # rs, s⟩ ⇒⇩α t'"
proof(cases s)
case Undecided with assms seq show "γ,p⊢ ⟨r # rs, s⟩ ⇒⇩α t'" by fastforce
next
case Decision with assms show "γ,p⊢ ⟨r # rs, s⟩ ⇒⇩α t'"
by(auto simp: decision dest!: decisionD)
qed
subsection‹wf ruleset›
text‹
A @{typ "'a rule list"} here is well-formed (for a packet) if
▪ either the rules do not match
▪ or the action is not @{const Call}, not @{const Return}, not @{const Unknown}
›
definition wf_ruleset :: "('a, 'p) match_tac ⇒ 'p ⇒ 'a rule list ⇒ bool" where
"wf_ruleset γ p rs ≡ ∀r ∈ set rs.
(¬ matches γ (get_match r) (get_action r) p) ∨
(¬(∃chain. get_action r = Call chain) ∧ get_action r ≠ Return ∧ ¬(∃chain. get_action r = Goto chain) ∧ get_action r ≠ Unknown)"
lemma wf_ruleset_append: "wf_ruleset γ p (rs1@rs2) ⟷ wf_ruleset γ p rs1 ∧ wf_ruleset γ p rs2"
by(auto simp add: wf_ruleset_def)
lemma wf_rulesetD: assumes "wf_ruleset γ p (r # rs)" shows "wf_ruleset γ p [r]" and "wf_ruleset γ p rs"
using assms by(auto simp add: wf_ruleset_def)
lemma wf_ruleset_fst: "wf_ruleset γ p (Rule m a # rs) ⟷ wf_ruleset γ p [Rule m a] ∧ wf_ruleset γ p rs"
by(auto simp add: wf_ruleset_def)
lemma wf_ruleset_stripfst: "wf_ruleset γ p (r # rs) ⟹ wf_ruleset γ p (rs)"
by(simp add: wf_ruleset_def)
lemma wf_ruleset_rest: "wf_ruleset γ p (Rule m a # rs) ⟹ wf_ruleset γ p [Rule m a]"
by(simp add: wf_ruleset_def)
subsection‹Ternary Semantics (Function)›
fun approximating_bigstep_fun :: "('a, 'p) match_tac ⇒ 'p ⇒ 'a rule list ⇒ state ⇒ state" where
"approximating_bigstep_fun γ p [] s = s" |
"approximating_bigstep_fun γ p rs (Decision X) = (Decision X)" |
"approximating_bigstep_fun γ p ((Rule m a)#rs) Undecided = (if
¬ matches γ m a p
then
approximating_bigstep_fun γ p rs Undecided
else
case a of Accept ⇒ Decision FinalAllow
| Drop ⇒ Decision FinalDeny
| Reject ⇒ Decision FinalDeny
| Log ⇒ approximating_bigstep_fun γ p rs Undecided
| Empty ⇒ approximating_bigstep_fun γ p rs Undecided
)"
lemma approximating_bigstep_fun_induct[case_names Empty Decision Nomatch Match] : "
(⋀γ p s. P γ p [] s) ⟹
(⋀γ p r rs X. P γ p (r # rs) (Decision X)) ⟹
(⋀γ p m a rs.
¬ matches γ m a p ⟹ P γ p rs Undecided ⟹ P γ p (Rule m a # rs) Undecided) ⟹
(⋀γ p m a rs.
matches γ m a p ⟹ (a = Log ⟹ P γ p rs Undecided) ⟹ (a = Empty ⟹ P γ p rs Undecided) ⟹ P γ p (Rule m a # rs) Undecided) ⟹
P γ p rs s"
apply (rule approximating_bigstep_fun.induct[of P γ p rs s])
apply (simp_all)
by metis
lemma Decision_approximating_bigstep_fun: "approximating_bigstep_fun γ p rs (Decision X) = Decision X"
by(induction rs) (simp_all)
lemma approximating_bigstep_fun_induct_wf[case_names Empty Decision Nomatch MatchAccept MatchDrop MatchReject MatchLog MatchEmpty, consumes 1]:
"wf_ruleset γ p rs ⟹
(⋀γ p s. P γ p [] s) ⟹
(⋀γ p r rs X. P γ p (r # rs) (Decision X)) ⟹
(⋀γ p m a rs.
¬ matches γ m a p ⟹ P γ p rs Undecided ⟹ P γ p (Rule m a # rs) Undecided) ⟹
(⋀γ p m a rs.
matches γ m a p ⟹ a = Accept ⟹ P γ p (Rule m a # rs) Undecided) ⟹
(⋀γ p m a rs.
matches γ m a p ⟹ a = Drop ⟹ P γ p (Rule m a # rs) Undecided) ⟹
(⋀γ p m a rs.
matches γ m a p ⟹ a = Reject ⟹ P γ p (Rule m a # rs) Undecided) ⟹
(⋀γ p m a rs.
matches γ m a p ⟹ a = Log ⟹ P γ p rs Undecided ⟹ P γ p (Rule m a # rs) Undecided) ⟹
(⋀γ p m a rs.
matches γ m a p ⟹ a = Empty ⟹ P γ p rs Undecided ⟹ P γ p (Rule m a # rs) Undecided) ⟹
P γ p rs s"
proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
case Empty thus ?case by blast
next
case Decision thus ?case by blast
next
case Nomatch thus ?case by(simp add: wf_ruleset_def)
next
case (Match γ p m a) thus ?case
apply -
apply(frule wf_rulesetD(1), drule wf_rulesetD(2))
apply(simp)
apply(cases a)
apply(simp_all)
apply(auto simp add: wf_ruleset_def)
done
qed
lemma just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided[case_names Undecided]:
assumes "s = Undecided ⟹ approximating_bigstep_fun γ p rs1 s = approximating_bigstep_fun γ p rs2 s"
shows "approximating_bigstep_fun γ p rs1 s = approximating_bigstep_fun γ p rs2 s"
proof(cases s)
case Undecided thus ?thesis using assms by simp
next
case Decision thus ?thesis by (simp add: Decision_approximating_bigstep_fun)
qed
subsubsection‹Append, Prepend, Postpend, Composition›
lemma approximating_bigstep_fun_seq_wf: "⟦ wf_ruleset γ p rs⇩1⟧ ⟹
approximating_bigstep_fun γ p (rs⇩1 @ rs⇩2) s = approximating_bigstep_fun γ p rs⇩2 (approximating_bigstep_fun γ p rs⇩1 s)"
proof(induction γ p rs⇩1 s rule: approximating_bigstep_fun_induct)
qed(simp_all add: wf_ruleset_def Decision_approximating_bigstep_fun split: action.split)
text‹The state transitions from @{const Undecided} to @{const Undecided} if all intermediate states are @{const Undecided}›
lemma approximating_bigstep_fun_seq_Undecided_wf: "⟦ wf_ruleset γ p (rs1@rs2)⟧ ⟹
approximating_bigstep_fun γ p (rs1@rs2) Undecided = Undecided ⟷
approximating_bigstep_fun γ p rs1 Undecided = Undecided ∧ approximating_bigstep_fun γ p rs2 Undecided = Undecided"
proof(induction γ p rs1 Undecided rule: approximating_bigstep_fun_induct)
qed(simp_all add: wf_ruleset_def split: action.split)
lemma approximating_bigstep_fun_seq_Undecided_t_wf: "⟦ wf_ruleset γ p (rs1@rs2)⟧ ⟹
approximating_bigstep_fun γ p (rs1@rs2) Undecided = t ⟷
approximating_bigstep_fun γ p rs1 Undecided = Undecided ∧ approximating_bigstep_fun γ p rs2 Undecided = t ∨
approximating_bigstep_fun γ p rs1 Undecided = t ∧ t ≠ Undecided"
proof(induction γ p rs1 Undecided rule: approximating_bigstep_fun_induct)
case Empty thus ?case by(cases t) simp_all
next
case Nomatch thus ?case by(simp add: wf_ruleset_def)
next
case Match thus ?case by(auto simp add: wf_ruleset_def split: action.split)
qed
lemma approximating_bigstep_fun_wf_postpend: "wf_ruleset γ p rsA ⟹ wf_ruleset γ p rsB ⟹
approximating_bigstep_fun γ p rsA s = approximating_bigstep_fun γ p rsB s ⟹
approximating_bigstep_fun γ p (rsA@rsC) s = approximating_bigstep_fun γ p (rsB@rsC) s"
apply(induction γ p rsA s rule: approximating_bigstep_fun_induct_wf)
apply(simp_all add: approximating_bigstep_fun_seq_wf)
apply (metis Decision_approximating_bigstep_fun)+
done
lemma approximating_bigstep_fun_singleton_prepend:
assumes "approximating_bigstep_fun γ p rsB s = approximating_bigstep_fun γ p rsC s"
shows "approximating_bigstep_fun γ p (r#rsB) s = approximating_bigstep_fun γ p (r#rsC) s"
proof(cases s)
case Decision thus ?thesis by(simp add: Decision_approximating_bigstep_fun)
next
case Undecided
with assms show ?thesis by(cases r)(simp split: action.split)
qed
subsection‹Equality with @{term "γ,p⊢ ⟨rs, s⟩ ⇒⇩α t"} semantics›
lemma approximating_bigstep_wf: "γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Undecided ⟹ wf_ruleset γ p rs"
unfolding wf_ruleset_def
proof(induction rs Undecided Undecided rule: approximating_bigstep_induct)
case Skip thus ?case by simp
next
case Log thus ?case by auto
next
case Nomatch thus ?case by simp
next
case (Seq rs rs1 rs2 t)
from Seq approximating_bigstep_to_undecided have "t = Undecided" by fast
from this Seq show ?case by auto
qed
text‹only valid actions appear in this ruleset›
definition good_ruleset :: "'a rule list ⇒ bool" where
"good_ruleset rs ≡ ∀r ∈ set rs. (¬(∃chain. get_action r = Call chain) ∧ get_action r ≠ Return ∧ ¬(∃chain. get_action r = Goto chain) ∧ get_action r ≠ Unknown)"
lemma[code_unfold]: "good_ruleset rs = (∀r∈set rs. (case get_action r of Call chain ⇒ False | Return ⇒ False | Goto chain ⇒ False | Unknown ⇒ False | _ ⇒ True))"
unfolding good_ruleset_def
apply(rule Set.ball_cong)
apply(simp_all)
apply(rename_tac r)
by(case_tac "get_action r")(simp_all)
lemma good_ruleset_alt: "good_ruleset rs = (∀r∈set rs. get_action r = Accept ∨ get_action r = Drop ∨
get_action r = Reject ∨ get_action r = Log ∨ get_action r = Empty)"
unfolding good_ruleset_def
apply(rule Set.ball_cong)
apply(simp_all)
apply(rename_tac r)
by(case_tac "get_action r")(simp_all)
lemma good_ruleset_append: "good_ruleset (rs⇩1 @ rs⇩2) ⟷ good_ruleset rs⇩1 ∧ good_ruleset rs⇩2"
by(simp add: good_ruleset_alt, blast)
lemma good_ruleset_fst: "good_ruleset (r#rs) ⟹ good_ruleset [r]"
by(simp add: good_ruleset_def)
lemma good_ruleset_tail: "good_ruleset (r#rs) ⟹ good_ruleset rs"
by(simp add: good_ruleset_def)
text‹
@{term good_ruleset} is stricter than @{term wf_ruleset}. It can be easily checked with running code!
›
lemma good_imp_wf_ruleset: "good_ruleset rs ⟹ wf_ruleset γ p rs" by (metis good_ruleset_def wf_ruleset_def)
lemma simple_imp_good_ruleset: "simple_ruleset rs ⟹ good_ruleset rs"
by(simp add: simple_ruleset_def good_ruleset_def, fastforce)
lemma approximating_bigstep_fun_seq_semantics: "⟦ γ,p⊢ ⟨rs⇩1, s⟩ ⇒⇩α t ⟧ ⟹
approximating_bigstep_fun γ p (rs⇩1 @ rs⇩2) s = approximating_bigstep_fun γ p rs⇩2 t"
proof(induction rs⇩1 s t arbitrary: rs⇩2 rule: approximating_bigstep.induct)
qed(simp_all add: Decision_approximating_bigstep_fun)
lemma approximating_semantics_imp_fun: "γ,p⊢ ⟨rs, s⟩ ⇒⇩α t ⟹ approximating_bigstep_fun γ p rs s = t"
proof(induction rs s t rule: approximating_bigstep_induct)
qed(auto simp add: approximating_bigstep_fun_seq_semantics Decision_approximating_bigstep_fun)
lemma approximating_fun_imp_semantics: assumes "wf_ruleset γ p rs"
shows "approximating_bigstep_fun γ p rs s = t ⟹ γ,p⊢ ⟨rs, s⟩ ⇒⇩α t"
using assms proof(induction γ p rs s rule: approximating_bigstep_fun_induct_wf)
case (Empty γ p s)
thus "γ,p⊢ ⟨[], s⟩ ⇒⇩α t" using skip by(simp)
next
case (Decision γ p r rs X)
hence "t = Decision X" by simp
thus "γ,p⊢ ⟨r # rs, Decision X⟩ ⇒⇩α t" using decision by fast
next
case (Nomatch γ p m a rs)
thus "γ,p⊢ ⟨Rule m a # rs, Undecided⟩ ⇒⇩α t"
apply(rule_tac t=Undecided in seq_fst)
apply(simp add: nomatch)
apply(simp add: Nomatch.IH)
done
next
case (MatchAccept γ p m a rs)
hence "t = Decision FinalAllow" by simp
thus ?case by (metis MatchAccept.hyps accept decision seq_fst)
next
case (MatchDrop γ p m a rs)
hence "t = Decision FinalDeny" by simp
thus ?case by (metis MatchDrop.hyps drop decision seq_fst)
next
case (MatchReject γ p m a rs)
hence "t = Decision FinalDeny" by simp
thus ?case by (metis MatchReject.hyps reject decision seq_fst)
next
case (MatchLog γ p m a rs)
thus ?case
apply(simp)
apply(rule_tac t=Undecided in seq_fst)
apply(simp add: log)
apply(simp add: MatchLog.IH)
done
next
case (MatchEmpty γ p m a rs)
thus ?case
apply(simp)
apply(rule_tac t=Undecided in seq_fst)
apply(simp add: empty)
apply(simp add: MatchEmpty.IH)
done
qed
text‹Henceforth, we will use the @{term approximating_bigstep_fun} semantics, because they are easier.
We show that they are equal.
›
theorem approximating_semantics_iff_fun: "wf_ruleset γ p rs ⟹
γ,p⊢ ⟨rs, s⟩ ⇒⇩α t ⟷ approximating_bigstep_fun γ p rs s = t"
by (metis approximating_fun_imp_semantics approximating_semantics_imp_fun)
corollary approximating_semantics_iff_fun_good_ruleset: "good_ruleset rs ⟹
γ,p⊢ ⟨rs, s⟩ ⇒⇩α t ⟷ approximating_bigstep_fun γ p rs s = t"
by (metis approximating_semantics_iff_fun good_imp_wf_ruleset)
lemma approximating_bigstep_deterministic: "⟦ γ,p⊢ ⟨rs, s⟩ ⇒⇩α t; γ,p⊢ ⟨rs, s⟩ ⇒⇩α t' ⟧ ⟹ t = t'"
proof(induction arbitrary: t' rule: approximating_bigstep_induct)
case Seq thus ?case
by (metis (hide_lams, mono_tags) append_Nil2 approximating_bigstep_fun.simps(1) approximating_bigstep_fun_seq_semantics)
qed(auto dest: approximating_bigstepD)
lemma rm_LogEmpty_fun_semantics:
"approximating_bigstep_fun γ p (rm_LogEmpty rs) s = approximating_bigstep_fun γ p rs s"
proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
case Empty thus ?case by(simp)
next
case Decision thus ?case by(simp add: Decision_approximating_bigstep_fun)
next
case (Nomatch γ p m a rs) thus ?case by(cases a,simp_all)
next
case (Match γ p m a rs) thus ?case by(cases a,simp_all)
qed
lemma "γ,p⊢ ⟨rm_LogEmpty rs, s⟩ ⇒⇩α t ⟷ γ,p⊢ ⟨rs, s⟩ ⇒⇩α t"
apply(rule iffI)
apply(induction rs arbitrary: s t)
apply(simp_all)
apply(rename_tac r rs s t)
apply(case_tac r)
apply(simp)
apply(rename_tac m a)
apply(case_tac a)
apply(simp_all)
apply(auto intro: approximating_bigstep.intros )
apply(erule seqE_fst, simp add: seq_fst)
apply(erule seqE_fst, simp add: seq_fst)
apply (metis decision log nomatch_fst seq_fst state.exhaust)
apply(erule seqE_fst, simp add: seq_fst)
apply(erule seqE_fst, simp add: seq_fst)
apply(erule seqE_fst, simp add: seq_fst)
apply(erule seqE_fst, simp add: seq_fst)
apply (metis decision empty nomatch_fst seq_fst state.exhaust)
apply(erule seqE_fst, simp add: seq_fst)
apply(induction rs s t rule: approximating_bigstep_induct)
apply(auto intro: approximating_bigstep.intros)
apply(rename_tac m a)
apply(case_tac a)
apply(auto intro: approximating_bigstep.intros)
apply(rename_tac rs⇩1 rs⇩2 t t')
apply(drule_tac rs⇩1="rm_LogEmpty rs⇩1" and rs⇩2="rm_LogEmpty rs⇩2" in seq)
apply(simp_all)
using rm_LogEmpty_seq apply metis
done
lemma rm_LogEmpty_simple_but_Reject:
"good_ruleset rs ⟹ ∀r ∈ set (rm_LogEmpty rs). get_action r = Accept ∨ get_action r = Reject ∨ get_action r = Drop"
proof(induction rs)
case Nil thus ?case by(simp add: good_ruleset_def)
next
case (Cons r rs) thus ?case
apply(clarify)
apply(cases r, rename_tac m a, simp)
by(case_tac a) (auto simp add: good_ruleset_def)
qed
lemma rw_Reject_fun_semantics:
"wf_unknown_match_tac α ⟹
(approximating_bigstep_fun (β, α) p (rw_Reject rs) s = approximating_bigstep_fun (β, α) p rs s)"
proof(induction rs)
case Nil thus ?case by simp
next
case (Cons r rs)
thus ?case
apply(case_tac r, rename_tac m a, simp)
apply(case_tac a)
apply(case_tac [!] s)
apply(auto dest: wf_unknown_match_tacD_False1 wf_unknown_match_tacD_False2)
done
qed
lemma rmLogEmpty_rwReject_good_to_simple: "good_ruleset rs ⟹ simple_ruleset (rw_Reject (rm_LogEmpty rs))"
apply(drule rm_LogEmpty_simple_but_Reject)
apply(simp add: simple_ruleset_def)
apply(induction rs)
apply(simp_all)
apply(rename_tac r rs)
apply(case_tac r)
apply(rename_tac m a)
apply(case_tac a)
apply(simp_all)
done
subsection‹Matching›
lemma optimize_matches_option_generic:
assumes "∀ r ∈ set rs. P (get_match r) (get_action r)"
and "(⋀m m' a. P m a ⟹ f m = Some m' ⟹ matches γ m' a p = matches γ m a p)"
and "(⋀m a. P m a ⟹ f m = None ⟹ ¬ matches γ m a p)"
shows "approximating_bigstep_fun γ p (optimize_matches_option f rs) s = approximating_bigstep_fun γ p rs s"
using assms proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
case Decision thus ?case by (simp add: Decision_approximating_bigstep_fun)
next
case (Nomatch γ p m a rs) thus ?case
apply(simp)
apply(cases "f m")
apply(simp; fail)
apply(simp del: approximating_bigstep_fun.simps)
apply(rename_tac m')
apply(subgoal_tac "¬ matches γ m' a p")
apply(simp; fail)
using assms by blast
next
case (Match γ p m a rs) thus ?case
apply(cases "f m")
apply(simp; fail)
apply(simp del: approximating_bigstep_fun.simps)
apply(rename_tac m')
apply(subgoal_tac "matches γ m' a p")
apply(simp split: action.split; fail)
using assms by blast
qed(simp)
lemma optimize_matches_generic: "∀ r ∈ set rs. P (get_match r) (get_action r) ⟹
(⋀m a. P m a ⟹ matches γ (f m) a p = matches γ m a p) ⟹
approximating_bigstep_fun γ p (optimize_matches f rs) s = approximating_bigstep_fun γ p rs s"
unfolding optimize_matches_def
apply(rule optimize_matches_option_generic)
apply(simp; fail)
apply(simp split: if_split_asm)
apply blast
apply(simp split: if_split_asm)
using matcheq_matchNone_not_matches by fast
lemma optimize_matches_matches_fst: "matches γ (f m) a p ⟹ optimize_matches f (Rule m a # rs) = (Rule (f m) a)# optimize_matches f rs"
apply(simp add: optimize_matches_def)
by (meson matcheq_matchNone_not_matches)
lemma optimize_matches: "∀m a. matches γ (f m) a p = matches γ m a p ⟹ approximating_bigstep_fun γ p (optimize_matches f rs) s = approximating_bigstep_fun γ p rs s"
using optimize_matches_generic[where P="λ_ _. True"] by metis
lemma optimize_matches_opt_MatchAny_match_expr: "approximating_bigstep_fun γ p (optimize_matches opt_MatchAny_match_expr rs) s = approximating_bigstep_fun γ p rs s"
using optimize_matches opt_MatchAny_match_expr_correct by metis
lemma optimize_matches_a: "∀a m. matches γ m a = matches γ (f a m) a ⟹ approximating_bigstep_fun γ p (optimize_matches_a f rs) s = approximating_bigstep_fun γ p rs s"
proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
case (Match γ p m a rs) thus ?case by(case_tac a)(simp_all add: optimize_matches_a_def)
qed(simp_all add: optimize_matches_a_def)
lemma optimize_matches_a_simplers:
assumes "simple_ruleset rs" and "∀a m. a = Accept ∨ a = Drop ⟶ matches γ (f a m) a = matches γ m a"
shows "approximating_bigstep_fun γ p (optimize_matches_a f rs) s = approximating_bigstep_fun γ p rs s"
proof -
from assms(1) have "wf_ruleset γ p rs" by(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
from ‹wf_ruleset γ p rs› assms show "approximating_bigstep_fun γ p (optimize_matches_a f rs) s = approximating_bigstep_fun γ p rs s"
proof(induction γ p rs s rule: approximating_bigstep_fun_induct_wf)
case Nomatch thus ?case
apply(simp add: optimize_matches_a_def simple_ruleset_def)
apply(safe)
apply(simp_all)
done
next
case MatchReject thus ?case by(simp add: optimize_matches_a_def simple_ruleset_def)
qed(simp_all add: optimize_matches_a_def simple_ruleset_tail)
qed
lemma not_matches_removeAll: "¬ matches γ m a p ⟹
approximating_bigstep_fun γ p (removeAll (Rule m a) rs) Undecided = approximating_bigstep_fun γ p rs Undecided"
apply(induction γ p rs Undecided rule: approximating_bigstep_fun.induct)
apply(simp)
apply(simp split: action.split)
apply blast
done
end
Theory Datatype_Selectors
theory Datatype_Selectors
imports Main
begin
text‹
Running Example: ‹datatype_new iptrule_match = is_Src: Src (src_range: ipt_iprange)›
A discriminator ‹disc› tells whether a value is of a certain constructor.
Example: ‹is_Src›
A selector ‹sel› select the inner value.
Example: ‹src_range›
A constructor ‹C› constructs a value
Example: ‹Src›
The are well-formed if the belong together.
›
fun wf_disc_sel :: "(('a ⇒ bool) × ('a ⇒ 'b)) ⇒ ('b ⇒ 'a) ⇒ bool" where
"wf_disc_sel (disc, sel) C ⟷ (∀a. disc a ⟶ C (sel a) = a) ∧ (∀a. sel (C a) = a)"
declare wf_disc_sel.simps[simp del]
end
Theory IpAddresses
theory IpAddresses
imports IP_Addresses.IP_Address_toString
IP_Addresses.CIDR_Split
"../Common/WordInterval_Lists"
begin
lemma "ipset_from_cidr (ipv4addr_of_dotdecimal (0, 0, 0, 0)) 33 = {0}"
by(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def ipset_from_cidr_large_pfxlen)
definition all_but_those_ips :: "('i::len word × nat) list ⇒ ('i word × nat) list" where
"all_but_those_ips cidrips = cidr_split (wordinterval_invert (l2wi (map ipcidr_to_interval cidrips)))"
lemma all_but_those_ips:
"ipcidr_union_set (set (all_but_those_ips cidrips)) =
UNIV - (⋃ (ip,n) ∈ set cidrips. ipset_from_cidr ip n)"
apply(simp add: )
unfolding ipcidr_union_set_uncurry all_but_those_ips_def
apply(simp add: cidr_split_prefix)
apply(simp add: l2wi)
apply(simp add: ipcidr_to_interval_def)
using ipset_from_cidr_ipcidr_to_interval by blast
section‹IPv4 Addresses›
subsection‹IPv4 Addresses in IPTables Notation (how we parse it)›
context
notes [[typedef_overloaded]]
begin
datatype 'i ipt_iprange =
IpAddr "'i::len word"
| IpAddrNetmask "'i word" nat
| IpAddrRange "'i word" "'i word"
end
fun ipt_iprange_to_set :: "'i::len ipt_iprange ⇒ 'i word set" where
"ipt_iprange_to_set (IpAddrNetmask base m) = ipset_from_cidr base m" |
"ipt_iprange_to_set (IpAddr ip) = { ip }" |
"ipt_iprange_to_set (IpAddrRange ip1 ip2) = { ip1 .. ip2 }"
text‹@{term ipt_iprange_to_set} can only represent an empty set if it is an empty range.›
lemma ipt_iprange_to_set_nonempty: "ipt_iprange_to_set ip = {} ⟷
(∃ip1 ip2. ip = IpAddrRange ip1 ip2 ∧ ip1 > ip2)"
apply(cases ip)
apply(simp; fail)
apply(simp add: ipset_from_cidr_alt bitmagic_zeroLast_leq_or1Last; fail)
apply(simp add:linorder_not_le; fail)
done
text‹maybe this is necessary as code equation?›
lemma element_ipt_iprange_to_set[code_unfold]: "(addr::'i::len word) ∈ ipt_iprange_to_set X = (
case X of (IpAddrNetmask pre len) ⇒
(pre AND ((mask len) << (len_of (TYPE('i)) - len))) ≤ addr ∧
addr ≤ pre OR (mask (len_of (TYPE('i)) - len))
| IpAddr ip ⇒ (addr = ip)
| IpAddrRange ip1 ip2 ⇒ ip1 ≤ addr ∧ ip2 ≥ addr)"
apply(cases X)
apply(simp; fail)
apply(simp add: ipset_from_cidr_alt; fail)
apply(simp; fail)
done
lemma ipt_iprange_to_set_uncurry_IpAddrNetmask:
"ipt_iprange_to_set (uncurry IpAddrNetmask a) = uncurry ipset_from_cidr a"
by(simp split: uncurry_splits)
text‹IP address ranges to ‹(start, end)› notation›
fun ipt_iprange_to_interval :: "'i::len ipt_iprange ⇒ ('i word × 'i word)" where
"ipt_iprange_to_interval (IpAddr addr) = (addr, addr)" |
"ipt_iprange_to_interval (IpAddrNetmask pre len) = ipcidr_to_interval (pre, len)" |
"ipt_iprange_to_interval (IpAddrRange ip1 ip2) = (ip1, ip2)"
lemma ipt_iprange_to_interval: "ipt_iprange_to_interval ip = (s,e) ⟹ {s .. e} = ipt_iprange_to_set ip"
apply(cases ip)
apply(auto simp add: ipcidr_to_interval)
done
text‹A list of IP address ranges to a @{typ "'i::len wordinterval"}.
The nice thing is: the usual set operations are defined on this type.
We can use the existing function @{const l2wi_intersect} if we want the intersection of the supplied list›
lemma "wordinterval_to_set (l2wi_intersect (map ipt_iprange_to_interval ips)) =
(⋂ ip ∈ set ips. ipt_iprange_to_set ip)"
apply(simp add: l2wi_intersect)
using ipt_iprange_to_interval by blast
text‹We can use @{const l2wi} if we want the union of the supplied list›
lemma "wordinterval_to_set (l2wi (map ipt_iprange_to_interval ips)) = (⋃ ip ∈ set ips. ipt_iprange_to_set ip)"
apply(simp add: l2wi)
using ipt_iprange_to_interval by blast
text‹A list of (negated) IP address to a @{typ "'i::len wordinterval"}.›
definition ipt_iprange_negation_type_to_br_intersect ::
"'i::len ipt_iprange negation_type list ⇒ 'i wordinterval" where
"ipt_iprange_negation_type_to_br_intersect l = l2wi_negation_type_intersect (NegPos_map ipt_iprange_to_interval l)"
lemma ipt_iprange_negation_type_to_br_intersect: "wordinterval_to_set (ipt_iprange_negation_type_to_br_intersect l) =
(⋂ ip ∈ set (getPos l). ipt_iprange_to_set ip) - (⋃ ip ∈ set (getNeg l). ipt_iprange_to_set ip)"
apply(simp add: ipt_iprange_negation_type_to_br_intersect_def l2wi_negation_type_intersect NegPos_map_simps)
using ipt_iprange_to_interval by blast
text‹The @{typ "'i::len wordinterval"} can be translated back into a list of IP ranges.
If a list of intervals is enough, we can use @{const wi2l}.
If we need it in @{typ "'i::len ipt_iprange"}, we can use this function.›
definition wi_2_cidr_ipt_iprange_list :: "'i::len wordinterval ⇒ 'i ipt_iprange list" where
"wi_2_cidr_ipt_iprange_list r = map (uncurry IpAddrNetmask) (cidr_split r)"
lemma wi_2_cidr_ipt_iprange_list:
"(⋃ ip ∈ set (wi_2_cidr_ipt_iprange_list r). ipt_iprange_to_set ip) = wordinterval_to_set r"
proof -
have "(⋃ ip ∈ set (wi_2_cidr_ipt_iprange_list r). ipt_iprange_to_set ip) =
(⋃x∈set (cidr_split r). uncurry ipset_from_cidr x)"
unfolding wi_2_cidr_ipt_iprange_list_def by force
thus ?thesis using cidr_split_prefix by metis
qed
text‹For example, this allows the following transformation›
definition ipt_iprange_compress :: "'i::len ipt_iprange negation_type list ⇒ 'i ipt_iprange list" where
"ipt_iprange_compress = wi_2_cidr_ipt_iprange_list ∘ ipt_iprange_negation_type_to_br_intersect"
lemma ipt_iprange_compress: "(⋃ ip ∈ set (ipt_iprange_compress l). ipt_iprange_to_set ip) =
(⋂ ip ∈ set (getPos l). ipt_iprange_to_set ip) - (⋃ ip ∈ set (getNeg l). ipt_iprange_to_set ip)"
by (metis wi_2_cidr_ipt_iprange_list comp_apply ipt_iprange_compress_def ipt_iprange_negation_type_to_br_intersect)
definition normalized_cidr_ip :: "'i::len ipt_iprange ⇒ bool" where
"normalized_cidr_ip ip ≡ case ip of IpAddrNetmask _ _ ⇒ True | _ ⇒ False"
lemma wi_2_cidr_ipt_iprange_list_normalized_IpAddrNetmask:
"∀a'∈set (wi_2_cidr_ipt_iprange_list as). normalized_cidr_ip a'"
apply(clarify)
apply(simp add: wi_2_cidr_ipt_iprange_list_def normalized_cidr_ip_def)
by force
lemma ipt_iprange_compress_normalized_IpAddrNetmask:
"∀a'∈set (ipt_iprange_compress as). normalized_cidr_ip a'"
by(simp add: ipt_iprange_compress_def wi_2_cidr_ipt_iprange_list_normalized_IpAddrNetmask)
definition ipt_iprange_to_cidr :: "'i::len ipt_iprange ⇒ ('i word × nat) list" where
"ipt_iprange_to_cidr ips = cidr_split (iprange_interval (ipt_iprange_to_interval ips))"
lemma ipt_ipvange_to_cidr: "ipcidr_union_set (set (ipt_iprange_to_cidr ips)) = (ipt_iprange_to_set ips)"
apply(simp add: ipt_iprange_to_cidr_def)
apply(simp add: ipcidr_union_set_uncurry)
apply(case_tac "(ipt_iprange_to_interval ips)")
apply(simp add: ipt_iprange_to_interval cidr_split_prefix_single)
done
definition interval_to_wi_to_ipt_iprange :: "'i::len word ⇒ 'i word ⇒ 'i ipt_iprange" where
"interval_to_wi_to_ipt_iprange s e ≡
if s = e
then IpAddr s
else case cidr_split (WordInterval s e) of [(ip,nmask)] ⇒ IpAddrNetmask ip nmask
| _ ⇒ IpAddrRange s e"
lemma interval_to_wi_to_ipt_ipv4range: "ipt_iprange_to_set (interval_to_wi_to_ipt_iprange s e) = {s..e}"
proof -
from cidr_split_prefix_single[of s e] have
"cidr_split (WordInterval s e) = [(a, b)] ⟹ ipset_from_cidr a b = {s..e}" for a b
by(simp add: iprange_interval.simps)
thus ?thesis
by(simp add: interval_to_wi_to_ipt_iprange_def split: list.split)
qed
fun wi_to_ipt_iprange :: "'i::len wordinterval ⇒ 'i ipt_iprange list" where
"wi_to_ipt_iprange (WordInterval s e) = (if s > e then [] else
[interval_to_wi_to_ipt_iprange s e])" |
"wi_to_ipt_iprange (RangeUnion a b) = wi_to_ipt_iprange a @ wi_to_ipt_iprange b"
lemma wi_to_ipt_ipv4range: "⋃(set (map ipt_iprange_to_set (wi_to_ipt_iprange wi))) = wordinterval_to_set wi"
apply(induction wi)
apply(simp add: interval_to_wi_to_ipt_ipv4range)
apply(simp)
done
end
Theory L4_Protocol_Flags
theory L4_Protocol_Flags
imports Simple_Firewall.L4_Protocol
begin
section‹Matching TCP Flags›
datatype ipt_tcp_flags = TCP_Flags "tcp_flag set"
"tcp_flag set"
definition ipt_tcp_syn :: "ipt_tcp_flags" where
"ipt_tcp_syn ≡ TCP_Flags {TCP_SYN,TCP_RST,TCP_ACK,TCP_FIN} {TCP_SYN}"
fun match_tcp_flags :: "ipt_tcp_flags ⇒ tcp_flag set ⇒ bool" where
"match_tcp_flags (TCP_Flags fmask c) flags ⟷ (flags ∩ fmask) = c"
lemma "match_tcp_flags ipt_tcp_syn {TCP_SYN, TCP_URG, TCP_PSH}" by eval
lemma match_tcp_flags_nomatch: "¬ c ⊆ fmask ⟹ ¬ match_tcp_flags (TCP_Flags fmask c) pkt" by auto
definition ipt_tcp_flags_NoMatch :: "ipt_tcp_flags" where
"ipt_tcp_flags_NoMatch ≡ TCP_Flags {} {TCP_SYN}"
lemma ipt_tcp_flags_NoMatch: "¬ match_tcp_flags ipt_tcp_flags_NoMatch pkt" by(simp add: ipt_tcp_flags_NoMatch_def)
definition ipt_tcp_flags_Any :: ipt_tcp_flags where
"ipt_tcp_flags_Any ≡ TCP_Flags {} {}"
lemma ipt_tcp_flags_Any: "match_tcp_flags ipt_tcp_flags_Any pkt" by(simp add: ipt_tcp_flags_Any_def)
lemma ipt_tcp_flags_Any_isUNIV: "fmask = {} ∧ c = {} ⟷ (∀pkt. match_tcp_flags (TCP_Flags fmask c) pkt)" by auto
fun match_tcp_flags_conjunct :: "ipt_tcp_flags ⇒ ipt_tcp_flags ⇒ ipt_tcp_flags" where
"match_tcp_flags_conjunct (TCP_Flags fmask1 c1) (TCP_Flags fmask2 c2) = (
if c1 ⊆ fmask1 ∧ c2 ⊆ fmask2 ∧ fmask1 ∩ fmask2 ∩ c1 = fmask1 ∩ fmask2 ∩ c2
then (TCP_Flags (fmask1 ∪ fmask2) (c1 ∪ c2))
else ipt_tcp_flags_NoMatch)"
lemma match_tcp_flags_conjunct: "match_tcp_flags (match_tcp_flags_conjunct f1 f2) pkt ⟷ match_tcp_flags f1 pkt ∧ match_tcp_flags f2 pkt"
apply(cases f1, cases f2, simp)
apply(rename_tac fmask1 c1 fmask2 c2)
apply(intro conjI impI)
apply(elim conjE)
apply blast
apply(simp add: ipt_tcp_flags_NoMatch)
apply fast
done
declare match_tcp_flags_conjunct.simps[simp del]
text‹Same as @{const match_tcp_flags_conjunct}, but returns @{const None} if result cannot match anyway›
definition match_tcp_flags_conjunct_option :: "ipt_tcp_flags ⇒ ipt_tcp_flags ⇒ ipt_tcp_flags option" where
"match_tcp_flags_conjunct_option f1 f2 = (case match_tcp_flags_conjunct f1 f2 of (TCP_Flags fmask c) ⇒ if c ⊆ fmask then Some (TCP_Flags fmask c) else None)"
lemma "match_tcp_flags_conjunct_option ipt_tcp_syn (TCP_Flags {TCP_RST,TCP_ACK} {TCP_RST}) = None" by eval
lemma match_tcp_flags_conjunct_option_Some: "match_tcp_flags_conjunct_option f1 f2 = Some f3 ⟹
match_tcp_flags f1 pkt ∧ match_tcp_flags f2 pkt ⟷ match_tcp_flags f3 pkt"
apply(simp add: match_tcp_flags_conjunct_option_def split: ipt_tcp_flags.split_asm if_split_asm)
using match_tcp_flags_conjunct by blast
lemma match_tcp_flags_conjunct_option_None: "match_tcp_flags_conjunct_option f1 f2 = None ⟹
¬(match_tcp_flags f1 pkt ∧ match_tcp_flags f2 pkt)"
apply(simp add: match_tcp_flags_conjunct_option_def split: ipt_tcp_flags.split_asm if_split_asm)
using match_tcp_flags_conjunct match_tcp_flags_nomatch by metis
lemma match_tcp_flags_conjunct_option: "(case match_tcp_flags_conjunct_option f1 f2 of None ⇒ False | Some f3 ⇒ match_tcp_flags f3 pkt) ⟷ match_tcp_flags f1 pkt ∧ match_tcp_flags f2 pkt"
apply(simp split: option.split)
using match_tcp_flags_conjunct_option_Some match_tcp_flags_conjunct_option_None by blast
fun ipt_tcp_flags_equal :: "ipt_tcp_flags ⇒ ipt_tcp_flags ⇒ bool" where
"ipt_tcp_flags_equal (TCP_Flags fmask1 c1) (TCP_Flags fmask2 c2) = (
if c1 ⊆ fmask1 ∧ c2 ⊆ fmask2
then c1 = c2 ∧ fmask1 = fmask2
else (¬ c1 ⊆ fmask1) ∧ (¬ c2 ⊆ fmask2))"
context
begin
private lemma funny_set_falg_fmask_helper: "c2 ⊆ fmask2 ⟹ (c1 = c2 ∧ fmask1 = fmask2) = (∀pkt. (pkt ∩ fmask1 = c1) = (pkt ∩ fmask2 = c2))"
apply rule
apply presburger
apply(subgoal_tac "fmask1 = fmask2")
apply blast
proof -
assume a1: "c2 ⊆ fmask2"
assume a2: "∀pkt. (pkt ∩ fmask1 = c1) = (pkt ∩ fmask2 = c2)"
have f3: "⋀A Aa. (A::'a set) - - Aa = Aa - - A"
by (simp add: inf_commute)
have f4: "⋀A Aa. (A::'a set) - - (- Aa) = A - Aa"
by simp
have f5: "⋀A Aa Ab. (A::'a set) - - Aa - - Ab = A - - (Aa - - Ab)"
by blast
have f6: "⋀A Aa. (A::'a set) - (- A - Aa) = A"
by fastforce
have f7: "⋀A Aa. - (A::'a set) - - Aa = Aa - A"
using f4 f3 by presburger
have f8: "⋀A Aa. - (A::'a set) = - (A - Aa) - (A - - Aa)"
by blast
have f9: "c1 = - (- c1)"
by blast
have f10: "⋀A. A - c1 - c1 = A - c1"
by blast
have "⋀A. A - - (fmask1 - - fmask2) = c2 ∨ A - - fmask1 ≠ c1"
using f6 f5 a2 by (metis (no_types) Diff_Compl)
hence f11: "⋀A. - A - - (fmask1 - - fmask2) = c2 ∨ fmask1 - A ≠ c1"
using f7 by meson
have "c2 - fmask2 = {}"
using a1 by force
hence f12: "- c2 - (fmask2 - c2) = - fmask2"
by blast
hence "fmask2 - - c2 = c2"
by blast
hence f13: "fmask1 - - c2 = c1"
using f3 a2 by simp
hence f14: "c1 = c2"
using f11 by blast
hence f15: "fmask2 - (fmask1 - c1) = c1"
using f13 f10 f9 f8 f7 f3 a2 by (metis Diff_Compl)
have "fmask1 - (fmask2 - c1) = c1"
using f14 f12 f10 f9 f8 f4 f3 a2 by (metis Diff_Compl)
thus "fmask1 = fmask2"
using f15 by blast
qed
lemma ipt_tcp_flags_equal: "ipt_tcp_flags_equal f1 f2 ⟷ (∀pkt. match_tcp_flags f1 pkt = match_tcp_flags f2 pkt)"
apply(cases f1, cases f2, simp)
apply(rename_tac fmask1 c1 fmask2 c2)
apply(intro conjI impI)
using funny_set_falg_fmask_helper apply metis
apply blast
done
end
declare ipt_tcp_flags_equal.simps[simp del]
end
Theory Ports
theory Ports
imports
"HOL-Library.Word"
"../Common/WordInterval_Lists"
L4_Protocol_Flags
begin
section‹Ports (layer 4)›
text‹E.g. source and destination ports for TCP/UDP›
text‹list of (start, end) port ranges›
type_synonym raw_ports = "(16 word × 16 word) list"
fun ports_to_set :: "raw_ports ⇒ (16 word) set" where
"ports_to_set [] = {}" |
"ports_to_set ((s,e)#ps) = {s..e} ∪ ports_to_set ps"
lemma ports_to_set: "ports_to_set pts = ⋃ {{s..e} | s e . (s,e) ∈ set pts}"
proof(induction pts)
case Nil thus ?case by simp
next
case (Cons p pts) thus ?case by(cases p, simp, blast)
qed
text‹We can reuse the wordinterval theory to reason about ports›
lemma ports_to_set_wordinterval: "ports_to_set ps = wordinterval_to_set (l2wi ps)"
by(induction ps rule: l2wi.induct) (auto)
text‹inverting a raw listing of ports›
definition "raw_ports_invert" :: "raw_ports ⇒ raw_ports" where
"raw_ports_invert ps = wi2l (wordinterval_invert (l2wi ps))"
lemma raw_ports_invert: "ports_to_set (raw_ports_invert ps) = - ports_to_set ps"
by(auto simp add: raw_ports_invert_def l2wi_wi2l ports_to_set_wordinterval)
text‹A port always belongs to a protocol! We must not lose this information.
You should never use @{typ raw_ports} directly›
datatype ipt_l4_ports = L4Ports primitive_protocol raw_ports
end
Theory Conntrack_State
theory Conntrack_State
imports "../Common/Negation_Type" Simple_Firewall.Lib_Enum_toString
begin
datatype ctstate = CT_New | CT_Established | CT_Related | CT_Untracked | CT_Invalid
text‹The state associated with a packet can be added as a tag to the packet.
See @{file ‹../Semantics_Stateful.thy›}.›
fun match_ctstate :: "ctstate set ⇒ ctstate ⇒ bool" where
"match_ctstate S s_tag ⟷ s_tag ∈ S"
fun ctstate_conjunct :: "ctstate set ⇒ ctstate set ⇒ ctstate set option" where
"ctstate_conjunct S1 S2 = (if S1 ∩ S2 = {} then None else Some (S1 ∩ S2))"
value[code] "ctstate_conjunct {CT_Established, CT_New} {CT_New}"
lemma ctstate_conjunct_correct: "match_ctstate S1 pkt ∧ match_ctstate S2 pkt ⟷
(case ctstate_conjunct S1 S2 of None ⇒ False | Some S' ⇒ match_ctstate S' pkt)"
apply simp
by blast
lemma UNIV_ctstate: "UNIV = {CT_New, CT_Established, CT_Related, CT_Untracked, CT_Invalid}" using ctstate.exhaust by auto
instance ctstate :: finite
proof
from UNIV_ctstate show "finite (UNIV:: ctstate set)" using finite.simps by auto
qed
lemma "finite (S :: ctstate set)" by simp
instantiation "ctstate" :: enum
begin
definition "enum_ctstate = [CT_New, CT_Established, CT_Related, CT_Untracked, CT_Invalid]"
definition "enum_all_ctstate P ⟷ P CT_New ∧ P CT_Established ∧ P CT_Related ∧ P CT_Untracked ∧ P CT_Invalid"
definition "enum_ex_ctstate P ⟷ P CT_New ∨ P CT_Established ∨ P CT_Related ∨ P CT_Untracked ∨ P CT_Invalid"
instance proof
show "UNIV = set (enum_class.enum :: ctstate list)"
by(simp add: UNIV_ctstate enum_ctstate_def)
next
show "distinct (enum_class.enum :: ctstate list)"
by(simp add: enum_ctstate_def)
next
show "⋀P. (enum_class.enum_all :: (ctstate ⇒ bool) ⇒ bool) P = Ball UNIV P"
by(simp add: UNIV_ctstate enum_all_ctstate_def)
next
show "⋀P. (enum_class.enum_ex :: (ctstate ⇒ bool) ⇒ bool) P = Bex UNIV P"
by(simp add: UNIV_ctstate enum_ex_ctstate_def)
qed
end
definition ctstate_is_UNIV :: "ctstate set ⇒ bool" where
"ctstate_is_UNIV c ≡ CT_New ∈ c ∧ CT_Established ∈ c ∧ CT_Related ∈ c ∧ CT_Untracked ∈ c ∧ CT_Invalid ∈ c"
lemma ctstate_is_UNIV: "ctstate_is_UNIV c ⟷ c = UNIV"
unfolding ctstate_is_UNIV_def
apply(simp add: UNIV_ctstate)
apply(rule iffI)
apply(clarify)
using UNIV_ctstate apply fastforce
apply(simp)
done
value[code] "ctstate_is_UNIV {CT_Established}"
fun ctstate_toString :: "ctstate ⇒ string" where
"ctstate_toString CT_New = ''NEW''" |
"ctstate_toString CT_Established = ''ESTABLISHED''" |
"ctstate_toString CT_Related = ''RELATED''" |
"ctstate_toString CT_Untracked = ''UNTRACKED''" |
"ctstate_toString CT_Invalid = ''INVALID''"
definition ctstate_set_toString :: "ctstate set ⇒ string" where
"ctstate_set_toString S = list_separated_toString '','' ctstate_toString (enum_set_to_list S)"
lemma "ctstate_set_toString {CT_New, CT_New, CT_Established} = ''NEW,ESTABLISHED''" by eval
end
Theory Tagged_Packet
theory Tagged_Packet
imports Simple_Firewall.Simple_Packet Conntrack_State
begin
section‹Tagged Simple Packet›
text‹Packet constants are prefixed with ‹p››
text‹A packet tagged with the following phantom fields:
conntrack connection state›
text‹The idea to tag the connection state into the packet is sound.
See @{file ‹../Semantics_Stateful.thy›}›
record (overloaded) 'i tagged_packet = "'i::len simple_packet" +
p_tag_ctstate :: ctstate
value "⦇
p_iiface = ''eth1'', p_oiface = '''',
p_src = 0, p_dst = 0,
p_proto = TCP, p_sport = 0, p_dport = 0,
p_tcp_flags = {TCP_SYN},
p_payload = ''arbitrary payload'',
p_tag_ctstate = CT_New
⦈:: 32 tagged_packet"
definition simple_packet_tag
:: "ctstate ⇒ ('i::len, 'a) simple_packet_scheme ⇒ ('i::len, 'a) tagged_packet_scheme" where
"simple_packet_tag ct_state p ≡
⦇p_iiface = p_iiface p, p_oiface = p_oiface p, p_src = p_src p, p_dst = p_dst p, p_proto = p_proto p,
p_sport = p_sport p, p_dport = p_dport p, p_tcp_flags = p_tcp_flags p,
p_payload = p_payload p,
p_tag_ctstate = ct_state,
… = simple_packet.more p⦈"
definition tagged_packet_untag
:: "('i::len, 'a) tagged_packet_scheme ⇒ ('i::len, 'a) simple_packet_scheme" where
"tagged_packet_untag p ≡
⦇p_iiface = p_iiface p, p_oiface = p_oiface p, p_src = p_src p, p_dst = p_dst p, p_proto = p_proto p,
p_sport = p_sport p, p_dport = p_dport p, p_tcp_flags = p_tcp_flags p,
p_payload = p_payload p,
… = tagged_packet.more p⦈"
lemma "tagged_packet_untag (simple_packet_tag ct_state p) = p"
"simple_packet_tag ct_state (tagged_packet_untag p) = p⦇p_tag_ctstate := ct_state⦈"
apply(case_tac [!] p)
by(simp add: tagged_packet_untag_def simple_packet_tag_def)+
end
Theory Common_Primitive_Syntax
theory Common_Primitive_Syntax
imports "../Datatype_Selectors"
IpAddresses
Simple_Firewall.Iface
L4_Protocol_Flags Ports Tagged_Packet Conntrack_State
begin
section‹Primitive Matchers: Interfaces, IP Space, Layer 4 Ports Matcher›
text‹Primitive Match Conditions which only support interfaces, IPv4 addresses, layer 4 protocols, and layer 4 ports.
›
context
notes [[typedef_overloaded]]
begin
datatype 'i common_primitive =
is_Src: Src (src_sel: "'i::len ipt_iprange") |
is_Dst: Dst (dst_sel: "'i::len ipt_iprange") |
is_Iiface: IIface (iiface_sel: iface) |
is_Oiface: OIface (oiface_sel: iface) |
is_Prot: Prot (prot_sel: protocol) |
is_Src_Ports: Src_Ports (src_ports_sel: ipt_l4_ports) |
is_Dst_Ports: Dst_Ports (dst_ports_sel: ipt_l4_ports) |
is_MultiportPorts: MultiportPorts (multiportports_sel: ipt_l4_ports) |
is_L4_Flags: L4_Flags (l4_flags_sel: ipt_tcp_flags) |
is_CT_State: CT_State (ct_state_sel: "ctstate set") |
is_Extra: Extra (extra_sel: string)
end
lemma wf_disc_sel_common_primitive:
"wf_disc_sel (is_Src_Ports, src_ports_sel) Src_Ports"
"wf_disc_sel (is_Dst_Ports, dst_ports_sel) Dst_Ports"
"wf_disc_sel (is_Src, src_sel) Src"
"wf_disc_sel (is_Dst, dst_sel) Dst"
"wf_disc_sel (is_Iiface, iiface_sel) IIface"
"wf_disc_sel (is_Oiface, oiface_sel) OIface"
"wf_disc_sel (is_Prot, prot_sel) Prot"
"wf_disc_sel (is_L4_Flags, l4_flags_sel) L4_Flags"
"wf_disc_sel (is_CT_State, ct_state_sel) CT_State"
"wf_disc_sel (is_Extra, extra_sel) Extra"
"wf_disc_sel (is_MultiportPorts, multiportports_sel) MultiportPorts"
by(simp_all add: wf_disc_sel.simps)
value "⦇p_iiface = ''eth0'', p_oiface = ''eth1'',
p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {TCP_ACK},
p_payload = ''GET / HTTP/1.0'',
p_tag_ctstate = CT_Established⦈ :: 32 tagged_packet"
end
Theory Unknown_Match_Tacs
theory Unknown_Match_Tacs
imports Matching_Ternary
begin
section‹Approximate Matching Tactics›
text‹in-doubt-tactics›
fun in_doubt_allow :: "'packet unknown_match_tac" where
"in_doubt_allow Accept _ = True" |
"in_doubt_allow Drop _ = False" |
"in_doubt_allow Reject _ = False" |
"in_doubt_allow _ _ = undefined"
lemma wf_in_doubt_allow: "wf_unknown_match_tac in_doubt_allow"
unfolding wf_unknown_match_tac_def by(simp add: fun_eq_iff)
fun in_doubt_deny :: "'packet unknown_match_tac" where
"in_doubt_deny Accept _ = False" |
"in_doubt_deny Drop _ = True" |
"in_doubt_deny Reject _ = True" |
"in_doubt_deny _ _ = undefined"
lemma wf_in_doubt_deny: "wf_unknown_match_tac in_doubt_deny"
unfolding wf_unknown_match_tac_def by(simp add: fun_eq_iff)
lemma packet_independent_unknown_match_tacs:
"packet_independent_α in_doubt_allow"
"packet_independent_α in_doubt_deny"
by(simp_all add: packet_independent_α_def)
lemma Drop_neq_Accept_unknown_match_tacs:
"in_doubt_allow Drop ≠ in_doubt_allow Accept"
"in_doubt_deny Drop ≠ in_doubt_deny Accept"
by(simp_all add: fun_eq_iff)
corollary matches_induction_case_MatchNot_in_doubt_allow:
"∀ a. matches (β,in_doubt_allow) m' a p = matches (β,in_doubt_allow) m a p ⟹
matches (β,in_doubt_allow) (MatchNot m') a p = matches (β,in_doubt_allow) (MatchNot m) a p"
by(rule matches_induction_case_MatchNot) (simp_all add: Drop_neq_Accept_unknown_match_tacs packet_independent_unknown_match_tacs)
corollary matches_induction_case_MatchNot_in_doubt_deny:
"∀ a. matches (β,in_doubt_deny) m' a p = matches (β,in_doubt_deny) m a p ⟹
matches (β,in_doubt_deny) (MatchNot m') a p = matches (β,in_doubt_deny) (MatchNot m) a p"
by(rule matches_induction_case_MatchNot) (simp_all add: Drop_neq_Accept_unknown_match_tacs packet_independent_unknown_match_tacs)
end
Theory Common_Primitive_Matcher_Generic
theory Common_Primitive_Matcher_Generic
imports "../Semantics_Ternary/Semantics_Ternary"
Common_Primitive_Syntax
"../Semantics_Ternary/Unknown_Match_Tacs"
begin
subsection‹A Generic primitive matcher: Agnostic of IP Addresses›
text‹Generalized Definition agnostic of IP Addresses fro IPv4 and IPv6›
locale primitive_matcher_generic =
fixes β :: "('i::len common_primitive, ('i::len, 'a) tagged_packet_scheme) exact_match_tac"
assumes IIface: "∀ p i. β (IIface i) p = bool_to_ternary (match_iface i (p_iiface p))"
and OIface: "∀ p i. β (OIface i) p = bool_to_ternary (match_iface i (p_oiface p))"
and Prot: "∀ p proto. β (Prot proto) p = bool_to_ternary (match_proto proto (p_proto p))"
and Src_Ports: "∀ p proto ps. β (Src_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p ∧ p_sport p ∈ ports_to_set ps)"
and Dst_Ports: "∀ p proto ps. β (Dst_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p ∧ p_dport p ∈ ports_to_set ps)"
and MultiportsPorts: "∀ p proto ps. β (MultiportPorts (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p ∧ (p_sport p ∈ ports_to_set ps ∨ p_dport p ∈ ports_to_set ps))"
and L4_Flags: "∀ p flags. β (L4_Flags flags) p = bool_to_ternary (match_tcp_flags flags (p_tcp_flags p))"
and CT_State: "∀ p S. β (CT_State S) p = bool_to_ternary (match_ctstate S (p_tag_ctstate p))"
and Extra: "∀ p str. β (Extra str) p = TernaryUnknown"
begin
lemma Iface_single:
"matches (β, α) (Match (IIface X)) a p ⟷ match_iface X (p_iiface p)"
"matches (β, α) (Match (OIface X)) a p ⟷ match_iface X (p_oiface p)"
by(simp_all add: IIface OIface match_raw_ternary bool_to_ternary_simps
split: ternaryvalue.split)
text‹Since matching on the iface cannot be @{const TernaryUnknown}*, we can pull out negations.›
lemma Iface_single_not:
"matches (β, α) (MatchNot (Match (IIface X))) a p ⟷ ¬ match_iface X (p_iiface p)"
"matches (β, α) (MatchNot (Match (OIface X))) a p ⟷ ¬ match_iface X (p_oiface p)"
by(simp_all add: IIface OIface matches_case_ternaryvalue_tuple bool_to_ternary_simps
split: ternaryvalue.split)
lemma Prot_single:
"matches (β, α) (Match (Prot X)) a p ⟷ match_proto X (p_proto p)"
by(simp add: Prot match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split)
lemma Prot_single_not:
"matches (β, α) (MatchNot (Match (Prot X))) a p ⟷ ¬ match_proto X (p_proto p)"
by(simp add: Prot matches_case_ternaryvalue_tuple bool_to_ternary_simps split: ternaryvalue.split)
lemma Ports_single:
"matches (β, α) (Match (Src_Ports (L4Ports proto ps))) a p ⟷ proto = p_proto p ∧ p_sport p ∈ ports_to_set ps"
"matches (β, α) (Match (Dst_Ports (L4Ports proto ps))) a p ⟷ proto = p_proto p ∧ p_dport p ∈ ports_to_set ps"
by(simp_all add: Src_Ports Dst_Ports match_raw_ternary bool_to_ternary_simps
split: ternaryvalue.split)
lemma Ports_single_not:
"matches (β, α) (MatchNot (Match (Src_Ports (L4Ports proto ps)))) a p ⟷ proto ≠ p_proto p ∨ p_sport p ∉ ports_to_set ps"
"matches (β, α) (MatchNot (Match (Dst_Ports (L4Ports proto ps)))) a p ⟷ proto ≠ p_proto p ∨ p_dport p ∉ ports_to_set ps"
by(simp_all add: Src_Ports Dst_Ports matches_case_ternaryvalue_tuple bool_to_ternary_simps
split: ternaryvalue.split)
text‹Ports are dependent matches. They always match on the protocol too›
lemma Ports_single_rewrite_Prot:
"matches (β, α) (Match (Src_Ports (L4Ports proto ps))) a p ⟷
matches (β, α) (Match (Prot (Proto proto))) a p ∧ p_sport p ∈ ports_to_set ps"
"matches (β, α) (MatchNot (Match (Src_Ports (L4Ports proto ps)))) a p ⟷
matches (β, α) (MatchNot (Match (Prot (Proto proto)))) a p ∨ p_sport p ∉ ports_to_set ps"
"matches (β, α) (Match (Dst_Ports (L4Ports proto ps))) a p ⟷
matches (β, α) (Match (Prot (Proto proto))) a p ∧ p_dport p ∈ ports_to_set ps"
"matches (β, α) (MatchNot (Match (Dst_Ports (L4Ports proto ps)))) a p ⟷
matches (β, α) (MatchNot (Match (Prot (Proto proto)))) a p ∨ p_dport p ∉ ports_to_set ps"
by(auto simp add: Ports_single_not Ports_single Prot_single_not Prot_single)
lemma multiports_disjuction:
"(∃rg∈set spts. matches (β, α) (Match (Src_Ports (L4Ports proto [rg]))) a p) ⟷ matches (β, α) (Match (Src_Ports (L4Ports proto spts))) a p"
"(∃rg∈set dpts. matches (β, α) (Match (Dst_Ports (L4Ports proto [rg]))) a p) ⟷ matches (β, α) (Match (Dst_Ports (L4Ports proto dpts))) a p"
by(auto simp add: Src_Ports Dst_Ports match_raw_ternary bool_to_ternary_simps ports_to_set
split: ternaryvalue.split)
lemma MultiportPorts_single_rewrite:
"matches (β, α) (Match (MultiportPorts ports)) a p ⟷
matches (β, α) (Match (Src_Ports ports)) a p ∨ matches (β, α) (Match (Dst_Ports ports)) a p"
apply(cases ports)
apply(simp add: Ports_single)
by(simp add: MultiportsPorts match_raw_ternary bool_to_ternary_simps
split: ternaryvalue.split)
lemma MultiportPorts_single_rewrite_MatchOr:
"matches (β, α) (Match (MultiportPorts ports)) a p ⟷
matches (β, α) (MatchOr (Match (Src_Ports ports)) (Match (Dst_Ports ports))) a p"
apply(cases ports)
by(simp add: MatchOr MultiportPorts_single_rewrite)
lemma MultiportPorts_single_not_rewrite_MatchAnd:
"matches (β, α) (MatchNot (Match (MultiportPorts ports))) a p ⟷
matches (β, α) (MatchAnd (MatchNot (Match (Src_Ports ports))) (MatchNot (Match (Dst_Ports ports)))) a p"
apply(cases ports)
apply(simp add: Ports_single_not bunch_of_lemmata_about_matches)
by(simp add: MultiportsPorts matches_case_ternaryvalue_tuple bool_to_ternary_simps
split: ternaryvalue.split)
lemma MultiportPorts_single_not_rewrite:
"matches (β, α) (MatchNot (Match (MultiportPorts ports))) a p ⟷
¬ matches (β, α) (Match (Src_Ports ports)) a p ∧ ¬ matches (β, α) (Match (Dst_Ports ports)) a p"
apply(cases ports)
by(simp add: MultiportPorts_single_not_rewrite_MatchAnd bunch_of_lemmata_about_matches
Ports_single_not Ports_single)
Extra_single:
"matches (β, α) (Match (Extra str)) a p ⟷ α a p"
by(simp add: Extra match_raw_ternary)
Extra_single_not:
"matches (β, α) (MatchNot (Match (Extra str))) a p ⟷ α a p"
by(simp add: Extra matches_case_ternaryvalue_tuple)
end
subsection‹Basic optimisations›
text‹Compress many @{const Extra} expressions to one expression.›
fun compress_extra :: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr" where
"compress_extra (Match x) = Match x" |
"compress_extra (MatchNot (Match (Extra e))) = Match (Extra (''NOT (''@e@'')''))" |
"compress_extra (MatchNot m) = (MatchNot (compress_extra m))" |
"compress_extra (MatchAnd (Match (Extra e1)) m2) = (case compress_extra m2 of Match (Extra e2) ⇒ Match (Extra (e1@'' ''@e2)) | MatchAny ⇒ Match (Extra e1) | m2' ⇒ MatchAnd (Match (Extra e1)) m2')" |
"compress_extra (MatchAnd m1 m2) = MatchAnd (compress_extra m1) (compress_extra m2)" |
"compress_extra MatchAny = MatchAny"
thm compress_extra.simps
value [nbe] "compress_extra (MatchAnd (Match (Extra ''foo'')) (Match (Extra ''bar'')))"
value [nbe] "compress_extra (MatchAnd (Match (Extra ''foo'')) (MatchNot (Match (Extra ''bar''))))"
value [nbe] "compress_extra (MatchAnd (Match (Extra ''-m'')) (MatchAnd (Match (Extra ''addrtype'')) (MatchAnd (Match (Extra ''--dst-type'')) (MatchAnd (Match (Extra ''BROADCAST'')) MatchAny))))"
compress_extra_correct_matchexpr:
fixes β::"('i::len common_primitive, ('i::len, 'a) tagged_packet_scheme) exact_match_tac"
assumes generic: "primitive_matcher_generic β"
shows "matches (β, α) m = matches (β, α) (compress_extra m)"
proof(simp add: fun_eq_iff, clarify, rename_tac a p)
fix a and p :: "('i, 'a) tagged_packet_scheme"
from generic have "β (Extra e) p = TernaryUnknown" for e by(simp add: primitive_matcher_generic.Extra)
hence "ternary_ternary_eval (map_match_tac β p m) = ternary_ternary_eval (map_match_tac β p (compress_extra m))"
proof(induction m rule: compress_extra.induct)
case 4 thus ?case
by(simp_all split: match_expr.split match_expr.split_asm common_primitive.split)
qed (simp_all)
thus "matches (β, α) m a p = matches (β, α) (compress_extra m) a p"
by(rule matches_iff_apply_f)
qed
end
Theory Common_Primitive_Matcher
theory Common_Primitive_Matcher
imports Common_Primitive_Matcher_Generic
begin
subsection‹Primitive Matchers: IP Port Iface Matcher›
fun common_matcher :: "('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac" where
"common_matcher (IIface i) p = bool_to_ternary (match_iface i (p_iiface p))" |
"common_matcher (OIface i) p = bool_to_ternary (match_iface i (p_oiface p))" |
"common_matcher (Src ip) p = bool_to_ternary (p_src p ∈ ipt_iprange_to_set ip)" |
"common_matcher (Dst ip) p = bool_to_ternary (p_dst p ∈ ipt_iprange_to_set ip)" |
"common_matcher (Prot proto) p = bool_to_ternary (match_proto proto (p_proto p))" |
"common_matcher (Src_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p ∧ p_sport p ∈ ports_to_set ps)" |
"common_matcher (Dst_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p ∧ p_dport p ∈ ports_to_set ps)" |
"common_matcher (MultiportPorts (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p ∧ (p_sport p ∈ ports_to_set ps ∨ p_dport p ∈ ports_to_set ps))" |
"common_matcher (L4_Flags flags) p = bool_to_ternary (match_tcp_flags flags (p_tcp_flags p))" |
"common_matcher (CT_State S) p = bool_to_ternary (match_ctstate S (p_tag_ctstate p))" |
"common_matcher (Extra _) p = TernaryUnknown"
lemma packet_independent_β_unknown_common_matcher: "packet_independent_β_unknown common_matcher"
apply(simp add: packet_independent_β_unknown_def)
apply(clarify)
apply(rename_tac a p1 p2)
apply(case_tac a)
apply(simp_all add: bool_to_ternary_Unknown)
apply(rename_tac l4ports, case_tac l4ports; simp add: bool_to_ternary_Unknown; fail)+
done
lemma primitive_matcher_generic_common_matcher: "primitive_matcher_generic common_matcher"
by unfold_locales simp_all
text‹Warning: beware of the sloppy term `empty' portrange›
text‹An `empty' port range means it can never match! Basically, @{term "MatchNot (Match (Src_Ports (L4Ports proto [(0,65535)])))"} is False›
lemma "¬ matches (common_matcher, α) (MatchNot (Match (Src_Ports (L4Ports TCP [(0,65535)])))) a
⦇p_iiface = ''eth0'', p_oiface = ''eth1'',
p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
p_payload = '''', p_tag_ctstate = CT_New⦈"
by(simp add: primitive_matcher_generic_common_matcher primitive_matcher_generic.Ports_single_not)
text‹An `empty' port range means it always matches! Basically, @{term "(MatchNot (Match (Src_Ports (L4Ports any []))))"} is True.
This corresponds to firewall behavior, but usually you cannot specify an empty portrange in firewalls, but omission of portrange means no-port-restrictions,
i.e. every port matches.›
lemma "matches (common_matcher, α) (MatchNot (Match (Src_Ports (L4Ports any [])))) a
⦇p_iiface = ''eth0'', p_oiface = ''eth1'',
p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
p_payload = '''', p_tag_ctstate = CT_New⦈"
by(simp add: primitive_matcher_generic_common_matcher primitive_matcher_generic.Ports_single_not)
text‹If not a corner case, portrange matching is straight forward.›
lemma "matches (common_matcher, α) (Match (Src_Ports (L4Ports TCP [(1024,4096), (9999, 65535)]))) a
⦇p_iiface = ''eth0'', p_oiface = ''eth1'',
p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
p_payload = '''', p_tag_ctstate = CT_New⦈"
"¬ matches (common_matcher, α) (Match (Src_Ports (L4Ports TCP [(1024,4096), (9999, 65535)]))) a
⦇p_iiface = ''eth0'', p_oiface = ''eth1'',
p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
p_proto=TCP, p_sport=5000, p_dport=80, p_tcp_flags = {},
p_payload = '''', p_tag_ctstate = CT_New⦈"
"¬matches (common_matcher, α) (MatchNot (Match (Src_Ports (L4Ports TCP [(1024,4096), (9999, 65535)])))) a
⦇p_iiface = ''eth0'', p_oiface = ''eth1'',
p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
p_payload = '''', p_tag_ctstate = CT_New⦈"
by(simp_all add: primitive_matcher_generic_common_matcher primitive_matcher_generic.Ports_single_not primitive_matcher_generic.Ports_single)
text‹Lemmas when matching on @{term Src} or @{term Dst}›
lemma common_matcher_SrcDst_defined:
"common_matcher (Src m) p ≠ TernaryUnknown"
"common_matcher (Dst m) p ≠ TernaryUnknown"
"common_matcher (Src_Ports ps) p ≠ TernaryUnknown"
"common_matcher (Dst_Ports ps) p ≠ TernaryUnknown"
"common_matcher (MultiportPorts ps) p ≠ TernaryUnknown"
apply(case_tac [!] m, case_tac [!] ps)
apply(simp_all add: bool_to_ternary_Unknown)
done
lemma common_matcher_SrcDst_defined_simp:
"common_matcher (Src x) p ≠ TernaryFalse ⟷ common_matcher (Src x) p = TernaryTrue"
"common_matcher (Dst x) p ≠ TernaryFalse ⟷ common_matcher (Dst x) p = TernaryTrue"
apply (metis eval_ternary_Not.cases common_matcher_SrcDst_defined(1) ternaryvalue.distinct(1))
apply (metis eval_ternary_Not.cases common_matcher_SrcDst_defined(2) ternaryvalue.distinct(1))
done
lemma match_simplematcher_SrcDst:
"matches (common_matcher, α) (Match (Src X)) a p ⟷ p_src p ∈ ipt_iprange_to_set X"
"matches (common_matcher, α) (Match (Dst X)) a p ⟷ p_dst p ∈ ipt_iprange_to_set X"
by(simp_all add: match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split)
lemma match_simplematcher_SrcDst_not:
"matches (common_matcher, α) (MatchNot (Match (Src X))) a p ⟷ p_src p ∉ ipt_iprange_to_set X"
"matches (common_matcher, α) (MatchNot (Match (Dst X))) a p ⟷ p_dst p ∉ ipt_iprange_to_set X"
apply(simp_all add: matches_case_ternaryvalue_tuple split: ternaryvalue.split)
apply(case_tac [!] X)
apply(simp_all add: bool_to_ternary_simps)
done
lemma common_matcher_SrcDst_Inter:
"(∀m∈set X. matches (common_matcher, α) (Match (Src m)) a p) ⟷ p_src p ∈ (⋂x∈set X. ipt_iprange_to_set x)"
"(∀m∈set X. matches (common_matcher, α) (Match (Dst m)) a p) ⟷ p_dst p ∈ (⋂x∈set X. ipt_iprange_to_set x)"
by(simp_all add: match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split)
subsection‹Basic optimisations›
text‹Perform very basic optimization. Remove matches to primitives which are essentially @{const MatchAny}›
fun optimize_primitive_univ :: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr" where
"optimize_primitive_univ (Match (Src (IpAddrNetmask _ 0))) = MatchAny" |
"optimize_primitive_univ (Match (Dst (IpAddrNetmask _ 0))) = MatchAny" |
"optimize_primitive_univ (Match (IIface iface)) = (if iface = ifaceAny then MatchAny else (Match (IIface iface)))" |
"optimize_primitive_univ (Match (OIface iface)) = (if iface = ifaceAny then MatchAny else (Match (OIface iface)))" |
"optimize_primitive_univ (Match (Prot ProtoAny)) = MatchAny" |
"optimize_primitive_univ (Match (L4_Flags (TCP_Flags m c))) = (if m = {} ∧ c = {} then MatchAny else (Match (L4_Flags (TCP_Flags m c))))" |
"optimize_primitive_univ (Match (CT_State ctstate)) = (if ctstate_is_UNIV ctstate then MatchAny else Match (CT_State ctstate))" |
"optimize_primitive_univ (Match m) = Match m" |
"optimize_primitive_univ (MatchNot m) = (MatchNot (optimize_primitive_univ m))" |
"optimize_primitive_univ (MatchAnd m1 m2) = MatchAnd (optimize_primitive_univ m1) (optimize_primitive_univ m2)" |
"optimize_primitive_univ MatchAny = MatchAny"
lemma optimize_primitive_univ_unchanged_primitives:
"optimize_primitive_univ (Match a) = (Match a) ∨ optimize_primitive_univ (Match a) = MatchAny"
by (induction "(Match a)" rule: optimize_primitive_univ.induct)
(auto split: if_split_asm)
lemma optimize_primitive_univ_correct_matchexpr: fixes m::"'i::len common_primitive match_expr"
shows "matches (common_matcher, α) m = matches (common_matcher, α) (optimize_primitive_univ m)"
proof(simp add: fun_eq_iff, clarify, rename_tac a p)
fix a and p :: "('i::len, 'a) tagged_packet_scheme"
have "65535 = (max_word::16 word)" by simp
then have port_range: "⋀s e port. s = 0 ∧ e = 0xFFFF ⟶ (port::16 word) ≤ 0xFFFF"
by (simp only:) simp
have "ternary_ternary_eval (map_match_tac common_matcher p m) = ternary_ternary_eval (map_match_tac common_matcher p (optimize_primitive_univ m))"
apply(induction m rule: optimize_primitive_univ.induct)
by(simp_all add: port_range match_ifaceAny ipset_from_cidr_0 ctstate_is_UNIV)
thus "matches (common_matcher, α) m a p = matches (common_matcher, α) (optimize_primitive_univ m) a p"
by(rule matches_iff_apply_f)
qed
corollary optimize_primitive_univ_correct: "approximating_bigstep_fun (common_matcher, α) p (optimize_matches optimize_primitive_univ rs) s =
approximating_bigstep_fun (common_matcher, α) p rs s"
using optimize_matches optimize_primitive_univ_correct_matchexpr by metis
subsection‹Abstracting over unknowns›
text‹remove @{const Extra} (i.e. @{const TernaryUnknown}) match expressions›
fun upper_closure_matchexpr :: "action ⇒ 'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr" where
"upper_closure_matchexpr _ MatchAny = MatchAny" |
"upper_closure_matchexpr Accept (Match (Extra _)) = MatchAny" |
"upper_closure_matchexpr Reject (Match (Extra _)) = MatchNot MatchAny" |
"upper_closure_matchexpr Drop (Match (Extra _)) = MatchNot MatchAny" |
"upper_closure_matchexpr _ (Match m) = Match m" |
"upper_closure_matchexpr Accept (MatchNot (Match (Extra _))) = MatchAny" |
"upper_closure_matchexpr Drop (MatchNot (Match (Extra _))) = MatchNot MatchAny" |
"upper_closure_matchexpr Reject (MatchNot (Match (Extra _))) = MatchNot MatchAny" |
"upper_closure_matchexpr a (MatchNot (MatchNot m)) = upper_closure_matchexpr a m" |
"upper_closure_matchexpr a (MatchNot (MatchAnd m1 m2)) =
(let m1' = upper_closure_matchexpr a (MatchNot m1); m2' = upper_closure_matchexpr a (MatchNot m2) in
(if m1' = MatchAny ∨ m2' = MatchAny
then MatchAny
else
if m1' = MatchNot MatchAny then m2' else
if m2' = MatchNot MatchAny then m1'
else
MatchNot (MatchAnd (MatchNot m1') (MatchNot m2')))
)" |
"upper_closure_matchexpr _ (MatchNot m) = MatchNot m" |
"upper_closure_matchexpr a (MatchAnd m1 m2) = MatchAnd (upper_closure_matchexpr a m1) (upper_closure_matchexpr a m2)"
lemma upper_closure_matchexpr_generic:
"a = Accept ∨ a = Drop ⟹ remove_unknowns_generic (common_matcher, in_doubt_allow) a m = upper_closure_matchexpr a m"
by(induction a m rule: upper_closure_matchexpr.induct)
(simp_all add: remove_unknowns_generic_simps2 bool_to_ternary_Unknown common_matcher_SrcDst_defined)
fun lower_closure_matchexpr :: "action ⇒ 'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr" where
"lower_closure_matchexpr _ MatchAny = MatchAny" |
"lower_closure_matchexpr Accept (Match (Extra _)) = MatchNot MatchAny" |
"lower_closure_matchexpr Reject (Match (Extra _)) = MatchAny" |
"lower_closure_matchexpr Drop (Match (Extra _)) = MatchAny" |
"lower_closure_matchexpr _ (Match m) = Match m" |
"lower_closure_matchexpr Accept (MatchNot (Match (Extra _))) = MatchNot MatchAny" |
"lower_closure_matchexpr Drop (MatchNot (Match (Extra _))) = MatchAny" |
"lower_closure_matchexpr Reject (MatchNot (Match (Extra _))) = MatchAny" |
"lower_closure_matchexpr a (MatchNot (MatchNot m)) = lower_closure_matchexpr a m" |
"lower_closure_matchexpr a (MatchNot (MatchAnd m1 m2)) =
(let m1' = lower_closure_matchexpr a (MatchNot m1); m2' = lower_closure_matchexpr a (MatchNot m2) in
(if m1' = MatchAny ∨ m2' = MatchAny
then MatchAny
else
if m1' = MatchNot MatchAny then m2' else
if m2' = MatchNot MatchAny then m1'
else
MatchNot (MatchAnd (MatchNot m1') (MatchNot m2')))
)" |
"lower_closure_matchexpr _ (MatchNot m) = MatchNot m" |
"lower_closure_matchexpr a (MatchAnd m1 m2) = MatchAnd (lower_closure_matchexpr a m1) (lower_closure_matchexpr a m2)"
lemma lower_closure_matchexpr_generic:
"a = Accept ∨ a = Drop ⟹ remove_unknowns_generic (common_matcher, in_doubt_deny) a m = lower_closure_matchexpr a m"
by(induction a m rule: lower_closure_matchexpr.induct)
(simp_all add: remove_unknowns_generic_simps2 bool_to_ternary_Unknown common_matcher_SrcDst_defined)
end
Theory Example_Semantics
theory Example_Semantics
imports Call_Return_Unfolding "Primitive_Matchers/Common_Primitive_Matcher"
begin
section‹Examples Big Step Semantics›
text‹We use a primitive matcher which always applies. We don't care about matching in this example.›
fun applies_Yes :: "('a, 'p) matcher" where
"applies_Yes m p = True"
lemma[simp]: "Semantics.matches applies_Yes MatchAny p" by simp
lemma[simp]: "Semantics.matches applies_Yes (Match e) p" by simp
definition "m=Match (Src (IpAddr (0::ipv4addr)))"
lemma[simp]: "Semantics.matches applies_Yes m p" by (simp add: m_def)
lemma "[''FORWARD'' ↦ [(Rule m Log), (Rule m Accept), (Rule m Drop)]],applies_Yes,p⊢
⟨[Rule MatchAny (Call ''FORWARD'')], Undecided⟩ ⇒ (Decision FinalAllow)"
apply(rule call_result)
apply(auto)
apply(rule seq_cons)
apply(auto intro:Semantics.log)
apply(rule seq_cons)
apply(auto intro: Semantics.accept)
apply(rule Semantics.decision)
done
lemma "[''FORWARD'' ↦ [(Rule m Log), (Rule m (Call ''foo'')), (Rule m Accept)],
''foo'' ↦ [(Rule m Log), (Rule m Return)]],applies_Yes,p⊢
⟨[Rule MatchAny (Call ''FORWARD'')], Undecided⟩ ⇒ (Decision FinalAllow)"
apply(rule call_result)
apply(auto)
apply(rule seq_cons)
apply(auto intro: Semantics.log)
apply(rule seq_cons)
apply(rule Semantics.call_return[where rs⇩1="[Rule m Log]" and rs⇩2="[]"])
apply(simp)+
apply(auto intro: Semantics.log)
apply(auto intro: Semantics.accept)
done
lemma "[''FORWARD'' ↦ [Rule m (Call ''foo''), Rule m Drop], ''foo'' ↦ []],applies_Yes,p⊢
⟨[Rule MatchAny (Call ''FORWARD'')], Undecided⟩ ⇒ (Decision FinalDeny)"
apply(rule call_result)
apply(auto)
apply(rule Semantics.seq_cons)
apply(rule Semantics.call_result)
apply(auto)
apply(rule Semantics.skip)
apply(auto intro: deny)
done
lemma "((λrs. process_call [''FORWARD'' ↦ [Rule m (Call ''foo''), Rule m Drop], ''foo'' ↦ []] rs)^^2)
[Rule MatchAny (Call ''FORWARD'')]
= [Rule (MatchAnd MatchAny m) Drop]" by eval
hide_const m
definition "pkt=⦇p_iiface=''+'', p_oiface=''+'', p_src=0, p_dst=0,
p_proto=TCP, p_sport=0, p_dport=0, p_tcp_flags = {TCP_SYN},
p_payload='''',p_tag_ctstate= CT_New⦈"
text‹We tune the primitive matcher to support everything we need in the example. Note that the undefined cases cannot be handled with these exact semantics!›
fun applies_exampleMatchExact :: "(32 common_primitive, 32 tagged_packet) matcher" where
"applies_exampleMatchExact (Src (IpAddr addr)) p ⟷ p_src p = addr" |
"applies_exampleMatchExact (Dst (IpAddr addr)) p ⟷ p_dst p = addr" |
"applies_exampleMatchExact (Prot ProtoAny) p ⟷ True" |
"applies_exampleMatchExact (Prot (Proto pr)) p ⟷ p_proto p = pr"
lemma "[''FORWARD'' ↦ [ Rule (MatchAnd (Match (Src (IpAddr 0))) (Match (Dst (IpAddr 0)))) Reject,
Rule (Match (Dst (IpAddr 0))) Log,
Rule (Match (Prot (Proto TCP))) Accept,
Rule (Match (Prot (Proto TCP))) Drop]
],applies_exampleMatchExact, pkt⦇p_src:=(ipv4addr_of_dotdecimal (1,2,3,4)), p_dst:=(ipv4addr_of_dotdecimal (0,0,0,0))⦈⊢
⟨[Rule MatchAny (Call ''FORWARD'')], Undecided⟩ ⇒ (Decision FinalAllow)"
apply(rule call_result)
apply(auto)
apply(rule Semantics.seq_cons)
apply(auto intro: Semantics.nomatch simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)
apply(rule Semantics.seq_cons)
apply(auto intro: Semantics.log simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)
apply(rule Semantics.seq_cons)
apply(auto simp add: pkt_def intro: Semantics.accept)
apply(auto intro: Semantics.decision)
done
end
Theory Alternative_Semantics
theory Alternative_Semantics
imports Semantics
begin
context begin
private inductive iptables_bigstep_ns :: "'a ruleset ⇒ ('a, 'p) matcher ⇒ 'p ⇒ 'a rule list ⇒ state ⇒ state ⇒ bool"
("_,_,_⊢ ⟨_, _⟩ ⇒⇩s _" [60,60,60,20,98,98] 89)
for Γ and γ and p where
skip: "Γ,γ,p⊢ ⟨[], t⟩ ⇒⇩s t" |
accept: "matches γ m p ⟹ Γ,γ,p⊢ ⟨Rule m Accept # rs, Undecided⟩ ⇒⇩s Decision FinalAllow" |
drop: "matches γ m p ⟹ Γ,γ,p⊢ ⟨Rule m Drop # rs, Undecided⟩ ⇒⇩s Decision FinalDeny" |
reject: "matches γ m p ⟹ Γ,γ,p⊢ ⟨Rule m Reject # rs, Undecided⟩ ⇒⇩s Decision FinalDeny" |
log: "matches γ m p ⟹ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩s t ⟹ Γ,γ,p⊢ ⟨Rule m Log # rs, Undecided⟩ ⇒⇩s t" |
empty: "matches γ m p ⟹ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩s t ⟹ Γ,γ,p⊢ ⟨Rule m Empty # rs, Undecided⟩ ⇒⇩s t" |
nms: "¬ matches γ m p ⟹ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩s t ⟹ Γ,γ,p⊢ ⟨Rule m a # rs, Undecided⟩ ⇒⇩s t" |
call_return: "⟦ matches γ m p; Γ chain = Some (rs⇩1 @ Rule m' Return # rs⇩2);
matches γ m' p; Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒⇩s Undecided; Γ,γ,p⊢ ⟨rrs, Undecided⟩ ⇒⇩s t ⟧ ⟹
Γ,γ,p⊢ ⟨Rule m (Call chain) # rrs, Undecided⟩ ⇒⇩s t" |
call_result: "⟦ matches γ m p; Γ chain = Some rs; Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩s Decision X ⟧ ⟹
Γ,γ,p⊢ ⟨Rule m (Call chain) # rrs, Undecided⟩ ⇒⇩s Decision X" |
call_no_result: "⟦ matches γ m p; Γ chain = Some rs; Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩s Undecided;
Γ,γ,p⊢ ⟨rrs, Undecided⟩ ⇒⇩s t ⟧ ⟹
Γ,γ,p⊢ ⟨Rule m (Call chain) # rrs, Undecided⟩ ⇒⇩s t"
private lemma a: "Γ,γ,p⊢ ⟨rs, s⟩ ⇒⇩s t ⟹ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
apply(induction rule: iptables_bigstep_ns.induct; (simp add: iptables_bigstep.intros;fail)?)
apply (meson iptables_bigstep.decision iptables_bigstep.accept seq_cons)
apply (meson iptables_bigstep.decision iptables_bigstep.drop seq_cons)
apply (meson iptables_bigstep.decision iptables_bigstep.reject seq_cons)
apply (meson iptables_bigstep.log seq_cons)
apply (meson iptables_bigstep.empty seq_cons)
apply (meson nomatch seq_cons)
subgoal using iptables_bigstep.call_return seq_cons by fastforce
apply (meson iptables_bigstep.decision iptables_bigstep.call_result seq_cons)
apply (meson iptables_bigstep.call_result seq'_cons)
done
private lemma empty_rs_stateD: assumes "Γ,γ,p⊢ ⟨[], s⟩ ⇒⇩s t" shows "t = s"
using assms by(cases rule: iptables_bigstep_ns.cases)
private lemma decided: "⟦Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒⇩s Decision X⟧ ⟹ Γ,γ,p⊢ ⟨rs⇩1@rs⇩2, Undecided⟩ ⇒⇩s Decision X"
proof(induction rs⇩1)
case Nil
then show ?case by (fast dest: empty_rs_stateD)
next
case (Cons a rs⇩1)
from Cons.prems show ?case
by(cases rule: iptables_bigstep_ns.cases; simp add: Cons.IH iptables_bigstep_ns.intros)
qed
private lemma decided_determ: "⟦Γ,γ,p⊢ ⟨rs⇩1, s⟩ ⇒⇩s t; s = Decision X⟧ ⟹ t = Decision X"
by(induction rule: iptables_bigstep_ns.induct; (simp add: iptables_bigstep_ns.intros;fail)?)
private lemma seq_ns:
"⟦Γ,γ,p⊢ ⟨rs⇩1, Undecided⟩ ⇒⇩s t; Γ,γ,p⊢ ⟨rs⇩2, t⟩ ⇒⇩s t'⟧ ⟹ Γ,γ,p⊢ ⟨rs⇩1@rs⇩2, Undecided⟩ ⇒⇩s t'"
proof (cases t, goal_cases)
case 1
from 1(1,2) show ?case unfolding 1 proof(induction rs⇩1)
case (Cons a rs⇩3)
then show ?case
apply -
apply(rule iptables_bigstep_ns.cases[OF Cons.prems(1)]; simp add: iptables_bigstep_ns.intros)
done
qed simp
next
case (2 X)
hence "t' = Decision X" by (simp add: decided_determ)
from 2(1) show ?case by (simp add: "2"(3) ‹t' = Decision X› decided)
qed
private lemma b: "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t ⟹ s = Undecided ⟹ Γ,γ,p⊢ ⟨rs, s⟩ ⇒⇩s t"
apply(induction rule: iptables_bigstep.induct; (simp add: iptables_bigstep_ns.intros;fail)?)
apply (metis decided decision seq_ns seq_progress skipD state.exhaust)
apply(metis call_no_result iptables_bigstep_ns.call_result iptables_bigstep_ns.skip state.exhaust)
done
private inductive iptables_bigstep_nz :: "'a ruleset ⇒ ('a, 'p) matcher ⇒ 'p ⇒ 'a rule list ⇒ state ⇒ bool"
("_,_,_⊢ _ ⇒⇩z _" [60,60,60,20,98] 89)
for Γ and γ and p where
skip: "Γ,γ,p ⊢ [] ⇒⇩z Undecided" |
accept: "matches γ m p ⟹ Γ,γ,p⊢ Rule m Accept # rs ⇒⇩z Decision FinalAllow" |
drop: "matches γ m p ⟹ Γ,γ,p⊢ Rule m Drop # rs ⇒⇩z Decision FinalDeny" |
reject: "matches γ m p ⟹ Γ,γ,p⊢ Rule m Reject # rs ⇒⇩z Decision FinalDeny" |
log: "matches γ m p ⟹ Γ,γ,p⊢ rs ⇒⇩z t ⟹ Γ,γ,p⊢ Rule m Log # rs ⇒⇩z t" |
empty: "matches γ m p ⟹ Γ,γ,p⊢ rs ⇒⇩z t ⟹ Γ,γ,p⊢ Rule m Empty # rs ⇒⇩z t" |
nms: "¬ matches γ m p ⟹ Γ,γ,p⊢ rs ⇒⇩z t ⟹ Γ,γ,p⊢ Rule m a # rs ⇒⇩z t" |
call_return: "⟦ matches γ m p; Γ chain = Some (rs⇩1 @ Rule m' Return # rs⇩2);
matches γ m' p; Γ,γ,p⊢ rs⇩1 ⇒⇩z Undecided; Γ,γ,p⊢ rrs ⇒⇩z t ⟧ ⟹
Γ,γ,p⊢ Rule m (Call chain) # rrs ⇒⇩z t" |
call_result: "⟦ matches γ m p; Γ chain = Some rs; Γ,γ,p⊢ rs ⇒⇩z Decision X ⟧ ⟹
Γ,γ,p⊢ Rule m (Call chain) # rrs ⇒⇩z Decision X" |
call_no_result: "⟦ matches γ m p; Γ chain = Some rs; Γ,γ,p⊢ rs ⇒⇩z Undecided;
Γ,γ,p⊢ rrs ⇒⇩z t ⟧ ⟹
Γ,γ,p⊢ Rule m (Call chain) # rrs ⇒⇩z t"
private lemma c: "Γ,γ,p⊢ rs ⇒⇩z t ⟹ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩s t"
by(induction rule: iptables_bigstep_nz.induct; simp add: iptables_bigstep_ns.intros)
private lemma d: "Γ,γ,p⊢ ⟨rs, s⟩ ⇒⇩s t ⟹ s = Undecided ⟹ Γ,γ,p⊢ rs ⇒⇩z t"
by(induction rule: iptables_bigstep_ns.induct; simp add: iptables_bigstep_nz.intros)
inductive iptables_bigstep_r :: "'a ruleset ⇒ ('a, 'p) matcher ⇒ 'p ⇒ 'a rule list ⇒ state ⇒ bool"
("_,_,_⊢ _ ⇒⇩r _" [60,60,60,20,98] 89)
for Γ and γ and p where
skip: "Γ,γ,p ⊢ [] ⇒⇩r Undecided" |
accept: "matches γ m p ⟹ Γ,γ,p⊢ Rule m Accept # rs ⇒⇩r Decision FinalAllow" |
drop: "matches γ m p ⟹ Γ,γ,p⊢ Rule m Drop # rs ⇒⇩r Decision FinalDeny" |
reject: "matches γ m p ⟹ Γ,γ,p⊢ Rule m Reject # rs ⇒⇩r Decision FinalDeny" |
return: "matches γ m p ⟹ Γ,γ,p⊢ Rule m Return # rs ⇒⇩r Undecided" |
log: "Γ,γ,p⊢ rs ⇒⇩r t ⟹ Γ,γ,p⊢ Rule m Log # rs ⇒⇩r t" |
empty: "Γ,γ,p⊢ rs ⇒⇩r t ⟹ Γ,γ,p⊢ Rule m Empty # rs ⇒⇩r t" |
nms: "¬ matches γ m p ⟹ Γ,γ,p⊢ rs ⇒⇩r t ⟹ Γ,γ,p⊢ Rule m a # rs ⇒⇩r t" |
call_result: "⟦ matches γ m p; Γ chain = Some rs; Γ,γ,p⊢ rs ⇒⇩r Decision X ⟧ ⟹
Γ,γ,p⊢ Rule m (Call chain) # rrs ⇒⇩r Decision X" |
call_no_result: "⟦ Γ chain = Some rs; Γ,γ,p⊢ rs ⇒⇩r Undecided;
Γ,γ,p⊢ rrs ⇒⇩r t ⟧ ⟹
Γ,γ,p⊢ Rule m (Call chain) # rrs ⇒⇩r t"
private lemma returning: "⟦Γ,γ,p⊢ rs⇩1 ⇒⇩r Undecided; matches γ m' p⟧
⟹ Γ,γ,p⊢ rs⇩1 @ Rule m' Return # rs⇩2 ⇒⇩r Undecided"
proof(induction rs⇩1)
case Nil
then show ?case by (simp add: return)
next
case (Cons a rs⇩3)
then show ?case by - (rule iptables_bigstep_r.cases[OF Cons.prems(1)]; simp add: iptables_bigstep_r.intros)
qed
private lemma e: "Γ,γ,p⊢ rs ⇒⇩z t ⟹ s = Undecided ⟹ Γ,γ,p⊢ rs ⇒⇩r t"
by(induction rule: iptables_bigstep_nz.induct; simp add: iptables_bigstep_r.intros returning)
definition "no_call_to c rs ≡ (∀r ∈ set rs. case get_action r of Call c' ⇒ c ≠ c' | _ ⇒ True)"
definition "all_chains p Γ rs ≡ (p rs ∧ (∀l rs. Γ l = Some rs ⟶ p rs))"
private lemma all_chains_no_call_upd: "all_chains (no_call_to c) Γ rs ⟹ (Γ(c ↦ x)),γ,p⊢ rs ⇒⇩z t ⟷ Γ,γ,p⊢ rs ⇒⇩z t"
proof (rule iffI, goal_cases)
case 1
from 1(2,1) show ?case
by(induction rule: iptables_bigstep_nz.induct;
(simp add: iptables_bigstep_nz.intros no_call_to_def all_chains_def split: if_splits;fail)?)
next
case 2
from 2(2,1) show ?case
by(induction rule: iptables_bigstep_nz.induct;
(simp add: iptables_bigstep_nz.intros no_call_to_def all_chains_def split: action.splits;fail)?)
qed
lemma updated_call: "Γ(c ↦ rs),γ,p⊢ rs ⇒⇩z t ⟹ matches γ m p ⟹ Γ(c ↦ rs),γ,p⊢ [Rule m (Call c)] ⇒⇩z t"
by(cases t; simp add: iptables_bigstep_nz.call_no_result iptables_bigstep_nz.call_result iptables_bigstep_nz.skip)
private lemma shows
log_nz: "Γ,γ,p⊢ rs ⇒⇩z t ⟹ Γ,γ,p⊢ Rule m Log # rs ⇒⇩z t"
and empty_nz: "Γ,γ,p⊢ rs ⇒⇩z t ⟹ Γ,γ,p⊢ Rule m Empty # rs ⇒⇩z t"
by (meson iptables_bigstep_nz.log iptables_bigstep_nz.empty iptables_bigstep_nz.nms)+
private lemma nz_empty_rs_stateD: assumes "Γ,γ,p⊢ [] ⇒⇩z t" shows "t = Undecided"
using assms by(cases rule: iptables_bigstep_nz.cases)
private lemma upd_callD: "Γ(c ↦ rs),γ,p⊢ [Rule m (Call c)] ⇒⇩z t ⟹ matches γ m p
⟹ (Γ(c ↦ rs),γ,p⊢ rs ⇒⇩z t ∨ (∃rs⇩1 rs⇩2 m'. rs = rs⇩1 @ Rule m' Return # rs⇩2 ∧ matches γ m' p ∧ Γ(c ↦ rs),γ,p⊢ rs⇩1 ⇒⇩z Undecided ∧ t = Undecided))"
by(subst (asm) iptables_bigstep_nz.simps) (auto dest!: nz_empty_rs_stateD)
private lemma partial_fun_upd: "(f(x ↦ y)) x = Some y" by(fact fun_upd_same)
lemma f: "Γ,γ,p⊢ rs ⇒⇩r t ⟹ matches γ m p ⟹ all_chains (no_call_to c) Γ rs ⟹
(Γ(c ↦ rs)),γ,p⊢ [Rule m (Call c)] ⇒⇩z t"
proof(induction rule: iptables_bigstep_r.induct; (simp add: iptables_bigstep_nz.intros;fail)?)
case (return m rs)
then show ?case by (metis append_Nil fun_upd_same iptables_bigstep_nz.call_return iptables_bigstep_nz.skip)
next
case (log rs t mx)
have ac: "all_chains (no_call_to c) Γ rs"
using log(4) by(simp add: all_chains_def no_call_to_def)
have *: "Γ(c ↦ Rule mx Log # rs⇩1 @ Rule m' Return # rs⇩2),γ,p⊢ [Rule m (Call c)] ⇒⇩z Undecided"
if "rs = rs⇩1 @ Rule m' Return # rs⇩2" "matches γ m' p"
"Γ(c ↦ rs⇩1 @ Rule m' Return # rs⇩2),γ,p⊢ rs⇩1 ⇒⇩z Undecided"
for rs⇩1 rs⇩2 m'
proof -
have ac2: "all_chains (no_call_to c) Γ rs⇩1" using log(4) that
by(simp add: all_chains_def no_call_to_def)
hence "Γ(c ↦ Rule mx Log # rs⇩1 @ Rule m' Return # rs⇩2),γ,p⊢ rs⇩1 ⇒⇩z Undecided"
using that(3) unfolding that by(simp add: all_chains_no_call_upd)
hence "Γ(c ↦ Rule mx Log # rs⇩1 @ Rule m' Return # rs⇩2),γ,p⊢ Rule mx Log # rs⇩1 ⇒⇩z Undecided"
by (simp add: log_nz)
thus ?thesis using that(1,2)
by(elim iptables_bigstep_nz.call_return[where rs⇩2=rs⇩2, OF ‹matches γ m p›, rotated]; simp add: iptables_bigstep_nz.skip)
qed
from log(2)[OF log(3) ac] show ?case
apply -
apply(drule upd_callD[OF _ ‹matches γ m p›])
apply(erule disjE)
subgoal
apply(rule updated_call[OF _ ‹matches γ m p›])
apply(rule log_nz)
apply(simp add: ac all_chains_no_call_upd)
done
using * by blast
next
case (empty rs t mx) text‹analogous›
have ac: "all_chains (no_call_to c) Γ rs"
using empty(4) by(simp add: all_chains_def no_call_to_def)
have *: "Γ(c ↦ Rule mx Empty # rs⇩1 @ Rule m' Return # rs⇩2),γ,p⊢ [Rule m (Call c)] ⇒⇩z Undecided"
if "rs = rs⇩1 @ Rule m' Return # rs⇩2" "matches γ m' p"
"Γ(c ↦ rs⇩1 @ Rule m' Return # rs⇩2),γ,p⊢ rs⇩1 ⇒⇩z Undecided"
for rs⇩1 rs⇩2 m'
proof -
have ac2: "all_chains (no_call_to c) Γ rs⇩1" using empty(4) that
by(simp add: all_chains_def no_call_to_def)
hence "Γ(c ↦ Rule mx Empty # rs⇩1 @ Rule m' Return # rs⇩2),γ,p⊢ rs⇩1 ⇒⇩z Undecided"
using that(3) unfolding that by(simp add: all_chains_no_call_upd)
hence "Γ(c ↦ Rule mx Empty # rs⇩1 @ Rule m' Return # rs⇩2),γ,p⊢ Rule mx Empty # rs⇩1 ⇒⇩z Undecided"
by (simp add: empty_nz)
thus ?thesis using that(1,2)
by(elim iptables_bigstep_nz.call_return[where rs⇩2=rs⇩2, OF ‹matches γ m p›, rotated]; simp add: iptables_bigstep_nz.skip)
qed
from empty(2)[OF empty(3) ac] show ?case
apply -
apply(drule upd_callD[OF _ ‹matches γ m p›])
apply(erule disjE)
subgoal
apply(rule updated_call[OF _ ‹matches γ m p›])
apply(rule empty_nz)
apply(simp add: ac all_chains_no_call_upd)
done
using * by blast
next
case (nms m' rs t a)
have ac: "all_chains (no_call_to c) Γ rs" using nms(5) by(simp add: all_chains_def no_call_to_def)
from nms.IH[OF nms(4) ac] show ?case
apply -
apply(drule upd_callD[OF _ ‹matches γ m p›])
apply(erule disjE)
subgoal
apply(rule updated_call[OF _ ‹matches γ m p›])
apply(rule iptables_bigstep_nz.nms[OF ‹¬ matches γ m' p›])
apply(simp add: ac all_chains_no_call_upd)
done
apply safe
subgoal for rs⇩1 rs⇩2 r
apply(subgoal_tac "all_chains (no_call_to c) Γ rs⇩1")
apply(subst (asm) all_chains_no_call_upd, assumption)
apply(subst (asm) all_chains_no_call_upd[symmetric], assumption)
apply(drule iptables_bigstep_nz.nms[where a=a, OF ‹¬ matches γ m' p›])
apply(erule (1) iptables_bigstep_nz.call_return[where rs⇩2=rs⇩2, OF ‹matches γ m p›, rotated])
apply(insert ac; simp add: all_chains_def no_call_to_def iptables_bigstep_nz.skip)+
done
done
next
case (call_result m' c' rs X rrs)
have acrs: "all_chains (no_call_to c) Γ rs" using call_result(2,6) by(simp add: all_chains_def no_call_to_def)
have cc: "c ≠ c'" using call_result(6) by(simp add: all_chains_def no_call_to_def)
have "Γ(c ↦ rs),γ,p⊢ [Rule m (Call c)] ⇒⇩z Decision X" using call_result.IH call_result.prems(1) acrs by blast
then show ?case
apply -
apply(drule upd_callD[OF _ ‹matches γ m p›])
apply(erule disjE)
subgoal
apply(rule updated_call[OF _ ‹matches γ m p›])
apply(rule iptables_bigstep_nz.call_result[where rs=rs, OF ‹matches γ m' p› ])
apply(simp add: cc[symmetric] call_result(2);fail)
apply(simp add: acrs all_chains_no_call_upd;fail)
done
apply safe
done
next
case (call_no_result c' rs rrs t m')
have acrs: "all_chains (no_call_to c) Γ rs" using call_no_result(1,7) by(simp add: all_chains_def no_call_to_def)
have acrrs: "all_chains (no_call_to c) Γ rrs" using call_no_result(7) by(simp add: all_chains_def no_call_to_def)
have acrs1: "all_chains (no_call_to c) Γ rs⇩1" if "rs = rs⇩1 @ rs⇩2" for rs⇩1 rs⇩2
using acrs that by(simp add: all_chains_def no_call_to_def)
have acrrs1: "all_chains (no_call_to c) Γ rs⇩1" if "rrs = rs⇩1 @ rs⇩2" for rs⇩1 rs⇩2
using acrrs that by(simp add: all_chains_def no_call_to_def)
have cc: "c ≠ c'" using call_no_result(7) by(simp add: all_chains_def no_call_to_def)
have *: "Γ(c ↦ rs),γ,p⊢ [Rule m (Call c)] ⇒⇩z Undecided" using call_no_result.IH call_no_result.prems(1) acrs by blast
have **: "Γ(c ↦ rrs),γ,p⊢ [Rule m (Call c)] ⇒⇩z t" by (simp add: acrrs call_no_result.IH(2) call_no_result.prems(1))
show ?case proof(cases ‹matches γ m' p›)
case True
from call_no_result(5)[OF ‹matches γ m p› acrrs] * show ?thesis
apply -
apply(drule upd_callD[OF _ ‹matches γ m p›])+
apply(elim disjE)
apply safe
subgoal
apply(rule updated_call[OF _ ‹matches γ m p›])
apply(rule iptables_bigstep_nz.call_no_result[where rs=rs, OF ‹matches γ m' p› ])
apply(simp add: cc[symmetric] call_no_result(1);fail)
apply(simp add: acrs all_chains_no_call_upd;fail)
apply(simp add: acrrs all_chains_no_call_upd)
done
subgoal for rs⇩1 rs⇩2 r
apply(rule updated_call[OF _ ‹matches γ m p›])
apply(rule call_return[OF ‹matches γ m' p›])
apply(simp add: cc[symmetric] call_no_result(1);fail)
apply(simp;fail)
apply(simp add: acrs1 all_chains_no_call_upd;fail)
apply(simp add: acrrs all_chains_no_call_upd)
done
subgoal for rs⇩1 rs⇩2 r
apply(rule call_return[where rs⇩1="Rule m' (Call c') # rs⇩1", OF ‹matches γ m p›])
apply(simp;fail)
apply(simp;fail)
apply(rule iptables_bigstep_nz.call_no_result[OF ‹matches γ m' p›])
apply(simp add: cc[symmetric] call_no_result(1);fail)
apply (meson acrs all_chains_no_call_upd)
apply(subst all_chains_no_call_upd; simp add: acrrs1 all_chains_no_call_upd; fail)
apply (simp add: iptables_bigstep_nz.skip;fail)
done
subgoal for rrs⇩1 rs⇩1 rrs⇩2 rs⇩2 rr r
apply(rule call_return[where rs⇩1="Rule m' (Call c') # rrs⇩1", OF ‹matches γ m p›])
apply(simp;fail)
apply(simp;fail)
apply(rule call_return[OF ‹matches γ m' p›])
apply(simp add: cc[symmetric] call_no_result(1);fail)
apply blast
apply (meson acrs1 all_chains_no_call_upd)
apply(subst all_chains_no_call_upd; simp add: acrrs1 all_chains_no_call_upd; fail)
apply (simp add: iptables_bigstep_nz.skip;fail)
done
done
next
case False
from iptables_bigstep_nz.nms[OF False] ** show ?thesis
apply -
apply(drule upd_callD[OF _ ‹matches γ m p›])+
apply(elim disjE)
subgoal
apply(rule updated_call[OF _ ‹matches γ m p›])
apply(rule iptables_bigstep_nz.nms[OF False])
apply(simp add: acrrs all_chains_no_call_upd)
done
apply safe
subgoal for rs⇩1 rs⇩2 r
apply(rule call_return[where rs⇩1="Rule m' (Call c') # rs⇩1", OF ‹matches γ m p›])
apply(simp;fail)
apply(simp;fail)
apply(rule iptables_bigstep_nz.nms[OF False])
apply(subst all_chains_no_call_upd; simp add: acrrs1 all_chains_no_call_upd; fail)
apply(simp add: iptables_bigstep_nz.skip;fail)
done
done
qed
qed
lemma r_skip_inv: "Γ,γ,p⊢ [] ⇒⇩r t ⟹ t = Undecided"
by(subst (asm) iptables_bigstep_r.simps) auto
lemma r_call_eq: "Γ c = Some rs ⟹ matches γ m p ⟹ Γ,γ,p⊢ [Rule m (Call c)] ⇒⇩r t ⟷ Γ,γ,p⊢ rs ⇒⇩r t"
apply(rule iffI)
subgoal
apply(subst (asm) iptables_bigstep_r.simps)
apply(auto dest: r_skip_inv)
done
subgoal
apply(cases t)
apply(erule iptables_bigstep_r.call_no_result)
apply(simp;fail)
apply(simp add: iptables_bigstep_r.skip;fail)
apply(simp)
apply(erule (2) iptables_bigstep_r.call_result)
done
by -
lemma call_eq: "Γ c = Some rs ⟹ matches γ m p ⟹ ∀r ∈ set rs. get_action r ≠ Return ⟹ Γ,γ,p⊢ ⟨[Rule m (Call c)],s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs,s⟩ ⇒ t"
apply(rule iffI)
subgoal
apply(subst (asm) iptables_bigstep.simps)
apply (auto)
apply (simp add: decision)
apply(erule rules_singleton_rev_E; simp; metis callD in_set_conv_decomp rule.sel(2) skipD)
done
by (metis decision iptables_bigstep.call_result iptables_bigstep_deterministic state.exhaust)
theorem r_eq_orig: "⟦all_chains (no_call_to c) Γ rs; Γ c = Some rs⟧ ⟹
Γ,γ,p⊢ rs ⇒⇩r t ⟷ Γ,γ,p⊢ ⟨[Rule MatchAny (Call c)], Undecided⟩ ⇒ t"
apply(rule iffI)
subgoal
apply(drule f[where m=MatchAny, THEN c, THEN a])
apply(simp;fail)
apply(simp;fail)
apply (metis fun_upd_triv)
done
subgoal
apply(subst r_call_eq[where m=MatchAny, symmetric])
apply(simp;fail)
apply(simp;fail)
apply(erule b[THEN d, THEN e, OF _ refl refl refl])
done
done
lemma r_no_call: "Γ,γ,p⊢ Rule MatchAny (Call c)#rs ⇒⇩r t ⟹ Γ c = None ⟹ False"
by(subst (asm) iptables_bigstep_r.simps) simp
lemma no_call: "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t ⟹ rs = [Rule MatchAny (Call c)] ⟹ s = Undecided ⟹ Γ c = None ⟹ False"
by (meson b d e r_no_call)
private corollary r_eq_orig': assumes "∀rs ∈ ran Γ. no_call_to c rs"
shows "Γ,γ,p⊢ [Rule MatchAny (Call c)] ⇒⇩r t ⟷ Γ,γ,p⊢ ⟨[Rule MatchAny (Call c)], Undecided⟩ ⇒ t"
proof -
show ?thesis proof (cases "Γ c")
fix rs
assume "Γ c = Some rs"
moreover hence "all_chains (no_call_to c) Γ rs" using assms by (simp add: all_chains_def ranI)
ultimately show ?thesis by(simp add: r_call_eq r_eq_orig)
next
assume "Γ c = None" thus ?thesis using r_no_call no_call by metis
qed
qed
lemma r_tail: assumes "Γ,γ,p⊢ rs1 ⇒⇩r Decision X" shows "Γ,γ,p⊢ rs1 @ rs2 ⇒⇩r Decision X"
proof -
have "Γ,γ,p⊢ rs1 ⇒⇩r t ⟹ t = Decision X ⟹ Γ,γ,p⊢ rs1 @ rs2 ⇒⇩r Decision X" for t
by(induction rule: iptables_bigstep_r.induct; simp add: iptables_bigstep_r.intros)
thus ?thesis using assms by blast
qed
lemma r_seq: "Γ,γ,p⊢ rs1 ⇒⇩r Undecided ⟹ ∀r ∈ set rs1. ¬(get_action r = Return ∧ matches γ (get_match r) p)
⟹ Γ,γ,p⊢ rs2 ⇒⇩r t ⟹ Γ,γ,p⊢ rs1 @ rs2 ⇒⇩r t"
proof(induction rs1)
case Nil
then show ?case by simp
next
case (Cons r rs1)
have p2: "∀r∈set rs1. ¬ (get_action r = Return ∧ matches γ (get_match r) p)"
"¬(get_action r = Return ∧ matches γ (get_match r) p)"
by (simp_all add: Cons.prems(2))
from Cons.prems(1) p2(2) Cons.IH[OF _ p2(1) Cons.prems(3)] show ?case
by(cases rule: iptables_bigstep_r.cases; simp add: iptables_bigstep_r.intros)
qed
lemma r_appendD: "Γ,γ,p⊢ rs1 @ rs2 ⇒⇩r t ⟹ ∃s. Γ,γ,p⊢ rs1 ⇒⇩r s"
proof(induction rs1)
case (Cons r rs1)
from Cons.prems Cons.IH show ?case by(cases rule: iptables_bigstep_r.cases) (auto intro: iptables_bigstep_r.intros)
qed (meson iptables_bigstep_r.skip)
corollary iptables_bigstep_r_eq: assumes "∀rs ∈ ran Γ. no_call_to c rs" "A = Accept ∨ A = Drop"
shows "Γ,γ,p⊢ [Rule MatchAny (Call c), Rule MatchAny A] ⇒⇩r t ⟷ Γ,γ,p⊢ ⟨[Rule MatchAny (Call c), Rule MatchAny A], Undecided⟩ ⇒ t"
proof -
show ?thesis proof (cases "Γ c")
fix rs
assume "Γ c = Some rs"
moreover hence "all_chains (no_call_to c) Γ rs" using assms by (simp add: all_chains_def ranI)
show ?thesis
apply(rule iffI[rotated])
apply(erule seqE_cons)
apply(subst (asm) r_eq_orig'[symmetric])
apply (simp add: assms(1);fail)
apply (meson assms(1) b d e r_eq_orig' seq'_cons)
apply(frule r_appendD[of _ _ _ "[Rule MatchAny (Call c)]" "[Rule MatchAny A]", simplified])
apply(subst (asm) r_eq_orig')
apply (simp add: assms(1);fail)
apply(clarsimp)
apply(subst (asm) r_eq_orig'[symmetric])
apply (simp add: assms(1);fail)
apply(subst (asm)(2) iptables_bigstep_r.simps)
apply(subst (asm)(1) iptables_bigstep_r.simps)
apply auto
apply (metis append_Cons append_Nil assms(1) decision matches.simps(4) r_call_eq r_eq_orig' seq)
apply (metis ‹all_chains (no_call_to c) Γ rs› calculation iptables_bigstep_deterministic option.inject r_eq_orig state.distinct(1))
subgoal using ‹all_chains (no_call_to c) Γ rs› calculation iptables_bigstep_deterministic r_eq_orig by fastforce
apply(subst (asm) r_eq_orig[rotated])
apply(assumption)
subgoal using ‹all_chains (no_call_to c) Γ rs› calculation by simp
apply(erule seq'_cons)
apply(subst (asm)(1) iptables_bigstep_r.simps)
apply(insert assms(2); auto simp add: iptables_bigstep.intros)
done
next
assume "Γ c = None" thus ?thesis using r_no_call no_call by (metis seqE_cons)
qed
qed
lemma ex_no_call: "finite S ⟹ ∃c. ∀(rs :: 'a rule list) ∈ S. no_call_to c rs"
proof -
assume fS: ‹finite S›
define called_c where "called_c rs = {c. ∃m. Rule m (Call c) ∈ set rs}" for rs :: "'a rule list"
define called_c' where "called_c' rs = set [c. r ← rs, c ← (case get_action r of Call c ⇒ [c] | _ ⇒ [])]"
for rs :: "'a rule list"
have cc: "called_c' rs = called_c rs" for rs
unfolding called_c'_def called_c_def
by(induction rs; simp add: Un_def) (auto; metis rule.collapse)
have f: "finite (called_c rs)" for rs unfolding cc[symmetric] called_c'_def by blast
have ncc: "no_call_to c rs ⟷ c ∉ called_c rs" for c rs
by(induction rs; auto simp add: no_call_to_def called_c_def split: action.splits) (metis rule.collapse)
have isu: "infinite (UNIV :: string set)" by (simp add: infinite_UNIV_listI)
have ff: "finite (⋃rs ∈ S. called_c rs)" using f fS by simp
then obtain c where ne: "c ∉ (⋃rs ∈ S. called_c rs)"
by (blast dest: ex_new_if_finite[OF isu])
thus ?thesis by(intro exI[where x=c]) (simp add: ncc)
qed
private lemma ex_no_call': "finite (dom Γ) ⟹ ∃c. Γ c = None ∧ (∀(rs :: 'a rule list) ∈ (ran Γ). no_call_to c rs)"
proof -
have *: "finite S ⟹ (dom M) = S ⟹ ∃m. M = map_of m" for M S
proof(induction arbitrary: M rule: finite.induct)
case emptyI
then show ?case by(intro exI[where x=Nil]) simp
next
case (insertI A a)
show ?case proof(cases "a ∈ A")
case True
then show ?thesis using insertI by (simp add: insert_absorb)
next
case False
hence "dom (M(a := None)) = A" using insertI.prems by simp
from insertI.IH[OF this] obtain m where "M(a := None) = map_of m" ..
then show ?thesis
by(intro exI[where x="(a, the (M a)) # m"]) (simp; metis domIff fun_upd_apply insertCI insertI.prems option.collapse)
qed
qed
have ran_alt: "ran f = (the o f) ` dom f" for f by(auto simp add: ran_def dom_def image_def)
assume fD: ‹finite (dom Γ)›
hence fS: ‹finite (ran Γ)› by(simp add: ran_alt)
define called_c where "called_c rs = {c. ∃m. Rule m (Call c) ∈ set rs}" for rs :: "'a rule list"
define called_c' where "called_c' rs = set [c. r ← rs, c ← (case get_action r of Call c ⇒ [c] | _ ⇒ [])]"
for rs :: "'a rule list"
have cc: "called_c' rs = called_c rs" for rs
unfolding called_c'_def called_c_def
by(induction rs; simp add: Un_def) (auto; metis rule.collapse)
have f: "finite (called_c rs)" for rs unfolding cc[symmetric] called_c'_def by blast
have ncc: "no_call_to c rs ⟷ c ∉ called_c rs" for c rs
by(induction rs; auto simp add: no_call_to_def called_c_def split: action.splits) (metis rule.collapse)
have isu: "infinite (UNIV :: string set)" by (simp add: infinite_UNIV_listI)
have ff: "finite (⋃rs ∈ ran Γ. called_c rs)" using f fS by simp
hence fff: "finite (dom Γ ∪ (⋃rs ∈ ran Γ. called_c rs))" using fD by simp
then obtain c where ne: "c ∉ (dom Γ ∪ (⋃rs ∈ ran Γ. called_c rs))" thm ex_new_if_finite
by (metis UNIV_I isu set_eqI)
thus ?thesis by(fastforce simp add: ncc)
qed
lemma all_chains_no_call_upd_r: "all_chains (no_call_to c) Γ rs ⟹ (Γ(c ↦ x)),γ,p⊢ rs ⇒⇩r t ⟷ Γ,γ,p⊢ rs ⇒⇩r t"
proof (rule iffI, goal_cases)
case 1
from 1(2,1) show ?case
by(induction rule: iptables_bigstep_r.induct;
(simp add: iptables_bigstep_r.intros no_call_to_def all_chains_def split: if_splits;fail)?)
next
case 2
from 2(2,1) show ?case
by(induction rule: iptables_bigstep_r.induct;
(simp add: iptables_bigstep_r.intros no_call_to_def all_chains_def split: action.splits;fail)?)
qed
lemma all_chains_no_call_upd_orig: "all_chains (no_call_to c) Γ rs ⟹ (Γ(c ↦ x)),γ,p⊢ ⟨rs,s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs,s⟩ ⇒ t"
proof (rule iffI, goal_cases)
case 1
from 1(2,1) show ?case
by(induction rs s t rule: iptables_bigstep.induct;
(simp add: iptables_bigstep.intros no_call_to_def all_chains_def split: if_splits;fail)?)
next
case 2
from 2(2,1) show ?case
by(induction rule: iptables_bigstep.induct;
(simp add: iptables_bigstep.intros no_call_to_def all_chains_def split: action.splits;fail)?)
qed
corollary r_eq_orig''': assumes "finite (ran Γ)" and "∀r ∈ set rs. get_action r ≠ Return"
shows "Γ,γ,p⊢ rs ⇒⇩r t ⟷ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ t"
proof -
from assms have "finite ({rs} ∪ (ran Γ))" by simp
from ex_no_call[OF this] obtain c where c: "(∀rs∈ran Γ. no_call_to c rs)" "no_call_to c rs" by blast
hence acnc: "all_chains (no_call_to c) Γ rs" unfolding all_chains_def by (simp add: ranI)
have ranaway: "∀rs∈ran (Γ(c ↦ rs)). no_call_to c rs"
proof -
{
fix rsa :: "'a rule list"
assume a1: "rsa ∈ ran (Γ(c ↦ rs))"
have "⋀R. rs ∈ R ∪ Collect (no_call_to c)"
using c(2) by force
then have "rsa ∈ ran (Γ(c := None)) ∪ Collect (no_call_to c)"
using a1 by (metis (no_types) Un_iff Un_insert_left fun_upd_same fun_upd_upd insert_absorb ran_map_upd)
then have "no_call_to c rsa"
by (metis (no_types) Un_iff c(1) mem_Collect_eq ranI ran_restrictD restrict_complement_singleton_eq)
}
thus ?thesis by simp
qed
have "Γ(c ↦ rs),γ,p⊢ rs ⇒⇩r t ⟷ Γ(c ↦ rs),γ,p⊢ ⟨rs, Undecided⟩ ⇒ t"
apply(subst r_call_eq[where c=c and m=MatchAny,symmetric])
apply(simp;fail)
apply(simp;fail)
apply(subst call_eq[where c=c and m=MatchAny,symmetric])
apply(simp;fail)
apply(simp;fail)
apply(simp add: assms;fail)
apply(rule r_eq_orig')
apply(fact ranaway)
done
thus ?thesis
apply -
apply(subst (asm) all_chains_no_call_upd_r[where x=rs, OF acnc])
apply(subst (asm) all_chains_no_call_upd_orig[where x=rs, OF acnc])
.
qed
end
end
Theory Semantics_Stateful
theory Semantics_Stateful
imports Semantics
begin
section‹Semantics Stateful›
subsection‹Model 1 -- Curried Stateful Matcher›
text‹Processing a packet with state can be modeled as follows:
The state is @{term σ}.
The primitive matcher @{term γ⇩σ} is a curried function where the first argument is the state and
it returns a stateless primitive matcher, i.e. @{term "γ = (γ⇩σ σ)"}.
With this stateless primitive matcher @{term γ}, the @{const iptables_bigstep} semantics are executed.
As entry point, the iptables built-in chains @{term "''INPUT''"}, @{term "''OUTPUT''"}, and @{term "''FORWARD''"} with their
default-policy (@{const Accept} or @{const Drop} are valid for iptables) are chosen.
The semantics must yield a @{term "Decision X"}.
Due to the default-policy, this is always the case if the ruleset is well-formed.
When a decision is made, the state @{term σ} is updated.›
inductive semantics_stateful ::
"'a ruleset ⇒
('σ ⇒ ('a, 'p) matcher) ⇒
('σ ⇒ final_decision ⇒ 'p ⇒ 'σ) ⇒
'σ ⇒
(string × action) ⇒
'p list ⇒
('p × final_decision) list ⇒
'σ ⇒
bool" for Γ and γ⇩σ and state_update and σ⇩0 where
"semantics_stateful Γ γ⇩σ state_update σ⇩0 (built_in_chain, default_policy) ps [] σ⇩0" |
"semantics_stateful Γ γ⇩σ state_update σ⇩0 (built_in_chain, default_policy) (p#ps) ps_processed σ' ⟹
Γ,(γ⇩σ σ'),p⊢ ⟨[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy],Undecided⟩ ⇒ Decision X ⟹
semantics_stateful Γ γ⇩σ state_update σ⇩0 (built_in_chain, default_policy) ps (ps_processed@[(p, X)]) (state_update σ' X p)"
lemma semantics_stateful_intro_process_one: "semantics_stateful Γ γ⇩σ state_upate σ⇩0 (built_in_chain, default_policy) (p#ps) ps_processed_old σ_old ⟹
Γ,γ⇩σ σ_old,p⊢ ⟨[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided⟩ ⇒ Decision X ⟹
σ' = state_upate σ_old X p ⟹
ps_processed = ps_processed_old@[(p, X)] ⟹
semantics_stateful Γ γ⇩σ state_upate σ⇩0 (built_in_chain, default_policy) ps ps_processed σ'"
by(auto intro: semantics_stateful.intros)
lemma semantics_stateful_intro_start: "σ⇩0 = σ' ⟹ ps_processed = [] ⟹
semantics_stateful Γ γ⇩σ state_upate σ⇩0 (built_in_chain, default_policy) ps ps_processed σ'"
by(auto intro: semantics_stateful.intros)
text‹Example below›
subsection‹Model 2 -- Packets Tagged with State Information›
text‹In this model, the matcher is completely stateless but packets are previously tagged with
(static) stateful information.›
inductive semantics_stateful_packet_tagging ::
"'a ruleset ⇒
('a, 'ptagged) matcher ⇒
('σ ⇒ 'p ⇒ 'ptagged) ⇒
('σ ⇒ final_decision ⇒ 'p ⇒ 'σ) ⇒
'σ ⇒
(string × action) ⇒
'p list ⇒
('p × final_decision) list ⇒
'σ ⇒
bool" for Γ and γ and packet_tagger and state_update and σ⇩0 where
"semantics_stateful_packet_tagging Γ γ packet_tagger state_update σ⇩0 (built_in_chain, default_policy) ps [] σ⇩0" |
"semantics_stateful_packet_tagging Γ γ packet_tagger state_update σ⇩0 (built_in_chain, default_policy) (p#ps) ps_processed σ' ⟹
Γ,γ,(packet_tagger σ' p)⊢ ⟨[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy],Undecided⟩ ⇒ Decision X ⟹
semantics_stateful_packet_tagging Γ γ packet_tagger state_update σ⇩0 (built_in_chain, default_policy) ps (ps_processed@[(p, X)]) (state_update σ' X p)"
lemma semantics_stateful_packet_tagging_intro_start: "σ⇩0 = σ' ⟹ ps_processed = [] ⟹
semantics_stateful_packet_tagging Γ γ packet_tagger state_upate σ⇩0 (built_in_chain, default_policy) ps ps_processed σ'"
by(auto intro: semantics_stateful_packet_tagging.intros)
lemma semantics_stateful_packet_tagging_intro_process_one:
"semantics_stateful_packet_tagging Γ γ packet_tagger state_upate σ⇩0 (built_in_chain, default_policy) (p#ps) ps_processed_old σ_old ⟹
Γ,γ,(packet_tagger σ_old p)⊢ ⟨[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided⟩ ⇒ Decision X ⟹
σ' = state_upate σ_old X p ⟹
ps_processed = ps_processed_old@[(p, X)] ⟹
semantics_stateful_packet_tagging Γ γ packet_tagger state_upate σ⇩0 (built_in_chain, default_policy) ps ps_processed σ'"
by(auto intro: semantics_stateful_packet_tagging.intros)
lemma semantics_bigstep_state_vs_tagged:
assumes "∀m::'m. stateful_matcher' σ m p = stateful_matcher_tagged' m (packet_tagger' σ p)"
shows "Γ,stateful_matcher' σ,p⊢ ⟨rs, Undecided⟩ ⇒ t ⟷
Γ,stateful_matcher_tagged',packet_tagger' σ p⊢ ⟨rs, Undecided⟩ ⇒ t"
proof -
{ fix m::"'m match_expr"
from assms have
"matches (stateful_matcher' σ) m p ⟷ matches stateful_matcher_tagged' m (packet_tagger' σ p)"
by(induction m) (simp_all)
} note matches_stateful_matcher_stateful_matcher_tagged=this
show ?thesis (is "?lhs ⟷ ?rhs")
proof
assume ?lhs
thus ?rhs
proof(induction rs Undecided t rule: iptables_bigstep_induct)
case (Seq _ _ _ t)
thus ?case
apply(cases t)
apply (simp add: seq)
apply(auto simp add: decision seq dest: decisionD)
done
qed(auto intro: iptables_bigstep.intros simp add: matches_stateful_matcher_stateful_matcher_tagged)
next
assume ?rhs
thus ?lhs
proof(induction rs Undecided t rule: iptables_bigstep_induct)
case (Seq _ _ _ t)
thus ?case
apply(cases t)
apply (simp add: seq)
apply(auto simp add: decision seq dest: decisionD)
done
qed(auto intro: iptables_bigstep.intros simp add: matches_stateful_matcher_stateful_matcher_tagged)
qed
qed
text‹Both semantics are equal›
theorem semantics_stateful_vs_tagged:
assumes "∀m σ p. stateful_matcher' σ m p = stateful_matcher_tagged' m (packet_tagger' σ p)"
shows "semantics_stateful rs stateful_matcher' state_update' σ⇩0 start ps ps_processed σ' =
semantics_stateful_packet_tagging rs stateful_matcher_tagged' packet_tagger' state_update' σ⇩0 start ps ps_processed σ'"
proof -
from semantics_bigstep_state_vs_tagged[of stateful_matcher' _ _ stateful_matcher_tagged' packet_tagger'] assms
have vs_tagged:
"rs,stateful_matcher' σ',p⊢ ⟨[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided⟩ ⇒ t ⟷
rs,stateful_matcher_tagged',packet_tagger' σ' p⊢ ⟨[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided⟩ ⇒ t"
for t p σ' built_in_chain default_policy by blast
from assms have stateful_matcher_eq:
"(λa b. stateful_matcher_tagged' a (packet_tagger' σ' b)) = stateful_matcher' σ'" for σ' by presburger
show ?thesis (is "?lhs ⟷ ?rhs")
proof
assume ?lhs thus ?rhs
proof(induction rule: semantics_stateful.induct)
case 1 thus ?case by(auto intro: semantics_stateful_packet_tagging_intro_start)[1]
next
case (2 built_in_chain default_policy p ps ps_processed σ')
from 2 have
"semantics_stateful_packet_tagging rs stateful_matcher_tagged' packet_tagger' state_update' σ⇩0 (built_in_chain, default_policy) (p # ps) ps_processed σ'"
by blast
with 2(2,3) show ?case
apply -
apply(rule semantics_stateful_packet_tagging_intro_process_one)
apply(simp_all add: vs_tagged)
done
qed
next
assume ?rhs thus ?lhs
proof(induction rule: semantics_stateful_packet_tagging.induct)
case 1 thus ?case by(auto intro: semantics_stateful_intro_start)
next
case (2 built_in_chain default_policy p ps ps_processed σ') thus ?case
apply -
apply(rule semantics_stateful_intro_process_one)
apply(simp_all add: stateful_matcher_eq vs_tagged)
done
qed
qed
qed
text‹Examples›
context
begin
subsection‹Example: Conntrack with curried matcher›
text‹We illustrate stateful semantics with a simple example. We allow matching on the states New
and Established. In addition, we introduce a primitive match to match on outgoing ssh packets (dst port = 22).
The state is managed in a state table where accepted connections are remembered.›
text‹SomePacket with source and destination port or something we don't know about›
private datatype packet = SomePacket "nat × nat" | OtherPacket
private datatype primitive_matches = New | Established | IsSSH
text‹In the state, we remember the packets which belong to an established connection.›
private datatype conntrack_state = State "packet set"
text‹The stateful primitive matcher: It is given the current state table.
If match on @{const Established}, the packet must be known in the state table.
If match on @{const New}, the packet must not be in the state table.
If match on @{const IsSSH}, the dst port of the packet must be 22.›
private fun stateful_matcher :: "conntrack_state ⇒ (primitive_matches, packet) matcher" where
"stateful_matcher (State state_table) = (λm p. m = Established ∧ p ∈ state_table ∨
m = New ∧ p ∉ state_table ∨
m = IsSSH ∧ (∃dst_port. p = SomePacket (22, dst_port)))"
text‹Connections are always bi-directional.›
private fun reverse_direction :: "packet ⇒ packet" where
"reverse_direction OtherPacket = OtherPacket" |
"reverse_direction (SomePacket (src, dst)) = SomePacket (dst,src)"
text‹If a packet is accepted, the state for its bi-directional connection is saved in the state table.›
private fun state_update' :: "conntrack_state ⇒ final_decision ⇒ packet ⇒ conntrack_state" where
"state_update' (State state_table) FinalAllow p = State (state_table ∪ {p, reverse_direction p})" |
"state_update' (State state_table) FinalDeny p = State state_table"
text‹Allow everything that is established and allow new ssh connections.
Drop everything else (default policy, see below)›
private definition "ruleset == [''INPUT'' ↦ [Rule (Match Established) Accept, Rule (MatchAnd (Match IsSSH) (Match New)) Accept]]"
text‹The @{const ruleset} does not allow @{const OtherPacket}›
lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop) []
[(OtherPacket, FinalDeny)] (State {})"
unfolding ruleset_def
apply(rule semantics_stateful_intro_process_one)
apply(simp_all)
apply(rule semantics_stateful_intro_start)
apply(simp_all)
apply(rule seq_cons)
apply(rule call_result)
apply(simp_all)
apply(rule seq_cons)
apply(auto intro: iptables_bigstep.intros)
done
text‹The @{const ruleset} allows ssh packets, i.e. any packets with destination port 22 in the @{const New} rule.
The state is updated such that everything which belongs to the connection will now be accepted.›
lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
[]
[(SomePacket (22, 1024), FinalAllow)]
(State {SomePacket (1024, 22), SomePacket (22, 1024)})"
unfolding ruleset_def
apply(rule semantics_stateful_intro_process_one)
apply(simp_all)
apply(rule semantics_stateful_intro_start)
apply(simp_all)
apply(rule seq_cons)
apply(rule call_result)
apply(simp_all)
apply(rule seq_cons)
apply(auto intro: iptables_bigstep.intros)
done
text‹If we continue with this state, answer packets are now allowed›
lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
[]
[(SomePacket (22, 1024), FinalAllow), (SomePacket (1024, 22), FinalAllow)]
(State {SomePacket (1024, 22), SomePacket (22, 1024)})"
unfolding ruleset_def
apply(rule semantics_stateful_intro_process_one)
apply(simp_all)
apply(rule semantics_stateful_intro_process_one)
apply(simp_all)
apply(rule semantics_stateful_intro_start)
apply(simp_all)
apply(rule seq_cons, rule call_result, simp_all, rule seq_cons)
apply(auto intro: iptables_bigstep.intros)
apply(rule seq_cons, rule call_result, simp_all, rule seq_cons)
apply(auto intro: iptables_bigstep.intros)
done
text‹In contrast, without having previously established a state, answer packets are prohibited›
text‹If we continue with this state, answer packets are now allowed›
lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
[]
[(SomePacket (1024, 22), FinalDeny), (SomePacket (22, 1024), FinalAllow), (SomePacket (1024, 22), FinalAllow)]
(State {SomePacket (1024, 22), SomePacket (22, 1024)})"
unfolding ruleset_def
apply(rule semantics_stateful_intro_process_one)
apply(simp_all)
apply(rule semantics_stateful_intro_process_one)
apply(simp_all)
apply(rule semantics_stateful_intro_process_one)
apply(simp_all)
apply(rule semantics_stateful_intro_start)
apply(simp_all)
apply(rule seq_cons, rule call_result, simp_all, rule seq_cons, auto intro: iptables_bigstep.intros)+
done
subsection‹Example: Conntrack with packet tagging›
datatype packet_tag = TagNew | TagEstablished
datatype packet_tagged = SomePacket_tagged "nat × nat × packet_tag" | OtherPacket_tagged packet_tag
fun get_packet_tag :: "packet_tagged ⇒ packet_tag" where
"get_packet_tag (SomePacket_tagged (_,_, tag)) = tag" |
"get_packet_tag (OtherPacket_tagged tag) = tag"
definition stateful_matcher_tagged :: "(primitive_matches, packet_tagged) matcher" where
"stateful_matcher_tagged ≡ λm p. m = Established ∧ (get_packet_tag p = TagEstablished) ∨
m = New ∧ (get_packet_tag p = TagNew) ∨
m = IsSSH ∧ (∃dst_port tag. p = SomePacket_tagged (22, dst_port, tag))"
fun calculate_packet_tag :: "conntrack_state ⇒ packet ⇒ packet_tag" where
"calculate_packet_tag (State state_table) p = (if p ∈ state_table then TagEstablished else TagNew)"
fun packet_tagger :: "conntrack_state ⇒ packet ⇒ packet_tagged" where
"packet_tagger σ (SomePacket (s,d)) = (SomePacket_tagged (s,d, calculate_packet_tag σ (SomePacket (s,d))))" |
"packet_tagger σ OtherPacket = (OtherPacket_tagged (calculate_packet_tag σ OtherPacket))"
text‹If a packet is accepted, the state for its bi-directional connection is saved in the state table.›
fun state_update_tagged :: "conntrack_state ⇒ final_decision ⇒ packet ⇒ conntrack_state" where
"state_update_tagged (State state_table) FinalAllow p = State (state_table ∪ {p, reverse_direction p})" |
"state_update_tagged (State state_table) FinalDeny p = State state_table"
text‹Both semantics are equal›
lemma "semantics_stateful rs stateful_matcher state_update' σ⇩0 start ps ps_processed σ' =
semantics_stateful_packet_tagging rs stateful_matcher_tagged packet_tagger state_update' σ⇩0 start ps ps_processed σ'"
apply(rule semantics_stateful_vs_tagged)
apply(intro allI, rename_tac m σ p)
apply(case_tac σ)
apply(case_tac p)
apply(simp_all add: stateful_matcher_tagged_def)
apply force
done
end
end
Theory Semantics_Goto
theory Semantics_Goto
imports Main Firewall_Common "Common/List_Misc" "HOL-Library.LaTeXsugar"
begin
section‹Big Step Semantics with Goto›
text‹
We extend the iptables semantics to support the goto action.
A goto directly continues processing at the start of the called chain.
It does not change the call stack.
In contrast to calls, goto does not return.
Consequently, everything behind a matching goto cannot be reached.
›
text‹
This theory is structured as follows.
Fist, the goto semantics are introduced.
Then, we show that those semantics are deterministic.
Finally, we present two methods to remove gotos.
The first unfolds goto.
The second replaces gotos with calls.
Finally, since the goto rules makes all proofs quite ugly, we never mention the goto semantics again.
As we have shown, we can get rid of the gotos easily, thus, we stick to the nicer iptables semantics without goto.
›
context
begin
subsection‹Semantics›
private type_synonym 'a ruleset = "string ⇀ 'a rule list"
private type_synonym ('a, 'p) matcher = "'a ⇒ 'p ⇒ bool"
qualified fun matches :: "('a, 'p) matcher ⇒ 'a match_expr ⇒ 'p ⇒ bool" where
"matches γ (MatchAnd e1 e2) p ⟷ matches γ e1 p ∧ matches γ e2 p" |
"matches γ (MatchNot me) p ⟷ ¬ matches γ me p" |
"matches γ (Match e) p ⟷ γ e p" |
"matches _ MatchAny _ ⟷ True"
qualified fun no_matching_Goto :: "('a, 'p) matcher ⇒ 'p ⇒ 'a rule list ⇒ bool" where
"no_matching_Goto _ _ [] ⟷ True" |
"no_matching_Goto γ p ((Rule m (Goto _))#rs) ⟷ ¬ matches γ m p ∧ no_matching_Goto γ p rs" |
"no_matching_Goto γ p (_#rs) ⟷ no_matching_Goto γ p rs"
inductive iptables_goto_bigstep :: "'a ruleset ⇒ ('a, 'p) matcher ⇒ 'p ⇒ 'a rule list ⇒ state ⇒ state ⇒ bool"
("_,_,_⊢⇩g ⟨_, _⟩ ⇒ _" [60,60,60,20,98,98] 89)
for Γ and γ and p where
skip: "Γ,γ,p⊢⇩g ⟨[], t⟩ ⇒ t" |
accept: "matches γ m p ⟹ Γ,γ,p⊢⇩g ⟨[Rule m Accept], Undecided⟩ ⇒ Decision FinalAllow" |
drop: "matches γ m p ⟹ Γ,γ,p⊢⇩g ⟨[Rule m Drop], Undecided⟩ ⇒ Decision FinalDeny" |
reject: "matches γ m p ⟹ Γ,γ,p⊢⇩g ⟨[Rule m Reject], Undecided⟩ ⇒ Decision FinalDeny" |
log: "matches γ m p ⟹ Γ,γ,p⊢⇩g ⟨[Rule m Log], Undecided⟩ ⇒ Undecided" |
empty: "matches γ m p ⟹ Γ,γ,p⊢⇩g ⟨[Rule m Empty], Undecided⟩ ⇒ Undecided" |
nomatch: "¬ matches γ m p ⟹ Γ,γ,p⊢⇩g ⟨[Rule m a], Undecided⟩ ⇒ Undecided" |
decision: "Γ,γ,p⊢⇩g ⟨rs, Decision X⟩ ⇒ Decision X" |
seq: "⟦Γ,γ,p⊢⇩g ⟨rs⇩1, Undecided⟩ ⇒ t; Γ,γ,p⊢⇩g ⟨rs⇩2, t⟩ ⇒ t'; no_matching_Goto γ p rs⇩1⟧ ⟹ Γ,γ,p⊢⇩g ⟨rs⇩1@rs⇩2, Undecided⟩ ⇒ t'" |
call_return: "⟦ matches γ m p; Γ chain = Some (rs⇩1@[Rule m' Return]@rs⇩2);
matches γ m' p; Γ,γ,p⊢⇩g ⟨rs⇩1, Undecided⟩ ⇒ Undecided;
no_matching_Goto γ p rs⇩1⟧ ⟹
Γ,γ,p⊢⇩g ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Undecided" |
call_result: "⟦ matches γ m p; Γ chain = Some rs; Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t ⟧ ⟹
Γ,γ,p⊢⇩g ⟨[Rule m (Call chain)], Undecided⟩ ⇒ t" |
goto_decision: "⟦ matches γ m p; Γ chain = Some rs; Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ Decision X ⟧ ⟹
Γ,γ,p⊢⇩g ⟨(Rule m (Goto chain))#rest, Undecided⟩ ⇒ Decision X" |
goto_no_decision: "⟦ matches γ m p; Γ chain = Some rs; Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ Undecided ⟧ ⟹
Γ,γ,p⊢⇩g ⟨(Rule m (Goto chain))#rest, Undecided⟩ ⇒ Undecided"
text‹
The semantic rules again in pretty format:
\begin{center}
@{thm[mode=Axiom] skip [no_vars]}\\[1ex]
@{thm[mode=Rule] accept [no_vars]}\\[1ex]
@{thm[mode=Rule] drop [no_vars]}\\[1ex]
@{thm[mode=Rule] reject [no_vars]}\\[1ex]
@{thm[mode=Rule] log [no_vars]}\\[1ex]
@{thm[mode=Rule] empty [no_vars]}\\[1ex]
@{thm[mode=Rule] nomatch [no_vars]}\\[1ex]
@{thm[mode=Rule] decision [no_vars]}\\[1ex]
@{thm[mode=Rule] seq [no_vars]} \\[1ex]
@{thm[mode=Rule] call_return [no_vars]}\\[1ex]
@{thm[mode=Rule] call_result [no_vars]}\\[1ex]
@{thm[mode=Rule] goto_decision [no_vars]}\\[1ex]
@{thm[mode=Rule] goto_no_decision [no_vars]}
\end{center}
›
private lemma deny:
"matches γ m p ⟹ a = Drop ∨ a = Reject ⟹ iptables_goto_bigstep Γ γ p [Rule m a] Undecided (Decision FinalDeny)"
by (auto intro: drop reject)
private lemma iptables_goto_bigstep_induct
[case_names
Skip Allow Deny Log Nomatch Decision Seq Call_return Call_result Goto_Decision Goto_no_Decision,
induct pred: iptables_goto_bigstep]:
"⟦ Γ,γ,p⊢⇩g ⟨rs,s⟩ ⇒ t;
⋀t. P [] t t;
⋀m a. matches γ m p ⟹ a = Accept ⟹ P [Rule m a] Undecided (Decision FinalAllow);
⋀m a. matches γ m p ⟹ a = Drop ∨ a = Reject ⟹ P [Rule m a] Undecided (Decision FinalDeny);
⋀m a. matches γ m p ⟹ a = Log ∨ a = Empty ⟹ P [Rule m a] Undecided Undecided;
⋀m a. ¬ matches γ m p ⟹ P [Rule m a] Undecided Undecided;
⋀rs X. P rs (Decision X) (Decision X);
⋀rs rs⇩1 rs⇩2 t t'. rs = rs⇩1 @ rs⇩2 ⟹ Γ,γ,p⊢⇩g ⟨rs⇩1,Undecided⟩ ⇒ t ⟹ P rs⇩1 Undecided t ⟹
Γ,γ,p⊢⇩g ⟨rs⇩2,t⟩ ⇒ t' ⟹ P rs⇩2 t t' ⟹ no_matching_Goto γ p rs⇩1 ⟹
P rs Undecided t';
⋀m a chain rs⇩1 m' rs⇩2. matches γ m p ⟹ a = Call chain ⟹
Γ chain = Some (rs⇩1 @ [Rule m' Return] @ rs⇩2) ⟹
matches γ m' p ⟹ Γ,γ,p⊢⇩g ⟨rs⇩1,Undecided⟩ ⇒ Undecided ⟹
no_matching_Goto γ p rs⇩1 ⟹ P rs⇩1 Undecided Undecided ⟹
P [Rule m a] Undecided Undecided;
⋀m a chain rs t. matches γ m p ⟹ a = Call chain ⟹ Γ chain = Some rs ⟹
Γ,γ,p⊢⇩g ⟨rs,Undecided⟩ ⇒ t ⟹ P rs Undecided t ⟹ P [Rule m a] Undecided t;
⋀m a chain rs rest X. matches γ m p ⟹ a = Goto chain ⟹ Γ chain = Some rs ⟹
Γ,γ,p⊢⇩g ⟨rs,Undecided⟩ ⇒ (Decision X) ⟹ P rs Undecided (Decision X) ⟹
P (Rule m a#rest) Undecided (Decision X);
⋀m a chain rs rest. matches γ m p ⟹ a = Goto chain ⟹ Γ chain = Some rs ⟹
Γ,γ,p⊢⇩g ⟨rs,Undecided⟩ ⇒ Undecided ⟹ P rs Undecided Undecided ⟹
P (Rule m a#rest) Undecided Undecided⟧ ⟹
P rs s t"
by (induction rule: iptables_goto_bigstep.induct) auto
subsubsection‹Forward reasoning›
private lemma decisionD: "Γ,γ,p⊢⇩g ⟨r, s⟩ ⇒ t ⟹ s = Decision X ⟹ t = Decision X"
by (induction rule: iptables_goto_bigstep_induct) auto
private lemma iptables_goto_bigstep_to_undecided: "Γ,γ,p⊢⇩g ⟨rs, s⟩ ⇒ Undecided ⟹ s = Undecided"
by (metis decisionD state.exhaust)
private lemma iptables_goto_bigstep_to_decision: "Γ,γ,p⊢⇩g ⟨rs, Decision Y⟩ ⇒ Decision X ⟹ Y = X"
by (metis decisionD state.inject)
private lemma skipD: "Γ,γ,p⊢⇩g ⟨r, s⟩ ⇒ t ⟹ r = [] ⟹ s = t"
by (induction rule: iptables_goto_bigstep.induct) auto
private lemma gotoD: "Γ,γ,p⊢⇩g ⟨r, s⟩ ⇒ t ⟹ r = [Rule m (Goto chain)] ⟹ s = Undecided ⟹ matches γ m p ⟹
∃ rs. Γ chain = Some rs ∧ Γ,γ,p⊢⇩g ⟨rs,s⟩ ⇒ t"
by (induction rule: iptables_goto_bigstep.induct) (auto dest: skipD elim: list_app_singletonE)
private lemma not_no_matching_Goto_singleton_cases: "¬ no_matching_Goto γ p [Rule m a] ⟷ (∃ chain. a = (Goto chain)) ∧ matches γ m p"
by(case_tac a) (simp_all)
private lemma no_matching_Goto_Cons: "no_matching_Goto γ p [r] ⟹ no_matching_Goto γ p rs ⟹ no_matching_Goto γ p (r#rs)"
by(cases r)(rename_tac m a, case_tac a, simp_all)
private lemma no_matching_Goto_head: "no_matching_Goto γ p (r#rs) ⟹ no_matching_Goto γ p [r]"
by(cases r)(rename_tac m a, case_tac a, simp_all)
private lemma no_matching_Goto_tail: "no_matching_Goto γ p (r#rs) ⟹ no_matching_Goto γ p rs"
by(cases r)(rename_tac m a, case_tac a, simp_all)
private lemma not_no_matching_Goto_cases:
assumes "¬ no_matching_Goto γ p rs" "rs ≠ []"
shows "∃rs1 m chain rs2. rs = rs1@(Rule m (Goto chain))#rs2 ∧ no_matching_Goto γ p rs1 ∧ matches γ m p"
using assms
proof(induction rs)
case Nil thus ?case by simp
next
case (Cons r rs)
note Cons_outer=this
from Cons have "¬ no_matching_Goto γ p (r # rs)" by simp
show ?case
proof(cases rs)
case Nil
obtain m a where "r = Rule m a" by (cases r) simp
with ‹¬ no_matching_Goto γ p (r # rs)› Nil not_no_matching_Goto_singleton_cases have "(∃ chain. a = (Goto chain)) ∧ matches γ m p" by metis
from this obtain chain where "a = (Goto chain)" and "matches γ m p" by blast
have "r # rs = [] @ Rule m (Goto chain) # []" "no_matching_Goto γ p []" "matches γ m p"
by (simp_all add: ‹a = Goto chain› ‹r = Rule m a› Nil ‹matches γ m p›)
thus ?thesis by blast
next
case(Cons r' rs')
with Cons_outer have "r # rs = r # r' # rs'" by simp
show ?thesis
proof(cases"no_matching_Goto γ p [r]")
case True
with ‹¬ no_matching_Goto γ p (r # rs)› have "¬ no_matching_Goto γ p rs" by (meson no_matching_Goto_Cons)
have "rs ≠ []" using Cons by simp
from Cons_outer(1)[OF ‹¬ no_matching_Goto γ p rs› ‹rs ≠ []›]
obtain rs1 m chain rs2 where "rs = rs1 @ Rule m (Goto chain) # rs2" "no_matching_Goto γ p rs1" "matches γ m p" by blast
with ‹r # rs = r # r' # rs'› ‹no_matching_Goto γ p [r]› no_matching_Goto_Cons
have "r # rs = r # rs1 @ Rule m (Goto chain) # rs2 ∧ no_matching_Goto γ p (r#rs1) ∧ matches γ m p" by fast
thus ?thesis
apply(rule_tac x="r#rs1" in exI)
by auto
next
case False
obtain m a where "r = Rule m a" by (cases r) simp
with False not_no_matching_Goto_singleton_cases have "(∃ chain. a = (Goto chain)) ∧ matches γ m p" by metis
from this obtain chain where "a = (Goto chain)" and "matches γ m p" by blast
have "r # rs = [] @ Rule m (Goto chain) # rs" "no_matching_Goto γ p []" "matches γ m p"
by (simp_all add: ‹a = Goto chain› ‹r = Rule m a› ‹matches γ m p›)
thus ?thesis by blast
qed
qed
qed
private lemma seq_cons_Goto_Undecided:
assumes "Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)], Undecided⟩ ⇒ Undecided"
and "¬ matches γ m p ⟹ Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ Undecided"
shows "Γ,γ,p⊢⇩g ⟨Rule m (Goto chain) # rs, Undecided⟩ ⇒ Undecided"
proof(cases "matches γ m p")
case True
from True assms have "∃rs. Γ chain = Some rs ∧ Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ Undecided" by(auto dest: gotoD)
with True show ?thesis using goto_no_decision by fast
next
case False
with assms have " Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)] @ rs, Undecided⟩ ⇒ Undecided" by(auto dest: seq)
with False show ?thesis by simp
qed
private lemma seq_cons_Goto_t:
"Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)], Undecided⟩ ⇒ t ⟹ matches γ m p ⟹ Γ,γ,p⊢⇩g ⟨Rule m (Goto chain) # rs, Undecided⟩ ⇒ t"
apply(frule gotoD)
apply(simp_all)
apply(clarify)
apply(cases t)
apply(auto intro: iptables_goto_bigstep.intros)
done
private lemma no_matching_Goto_append: "no_matching_Goto γ p (rs1@rs2) ⟷ no_matching_Goto γ p rs1 ∧ no_matching_Goto γ p rs2"
by(induction γ p rs1 rule: no_matching_Goto.induct) (simp_all)
private lemma no_matching_Goto_append1: "no_matching_Goto γ p (rs1@rs2) ⟹ no_matching_Goto γ p rs1"
using no_matching_Goto_append by fast
private lemma no_matching_Goto_append2: "no_matching_Goto γ p (rs1@rs2) ⟹ no_matching_Goto γ p rs2"
using no_matching_Goto_append by fast
private lemma seq_cons:
assumes "Γ,γ,p⊢⇩g ⟨[r],Undecided⟩ ⇒ t" and "Γ,γ,p⊢⇩g ⟨rs,t⟩ ⇒ t'" and "no_matching_Goto γ p [r]"
shows "Γ,γ,p⊢⇩g ⟨r#rs, Undecided⟩ ⇒ t'"
proof -
from assms have "Γ,γ,p⊢⇩g ⟨[r] @ rs, Undecided⟩ ⇒ t'" by (rule seq)
thus ?thesis by simp
qed
context
notes skipD[dest] list_app_singletonE[elim]
begin
lemma acceptD: "Γ,γ,p⊢⇩g ⟨r, s⟩ ⇒ t ⟹ r = [Rule m Accept] ⟹ matches γ m p ⟹ s = Undecided ⟹ t = Decision FinalAllow"
by (induction rule: iptables_goto_bigstep.induct) auto
lemma dropD: "Γ,γ,p⊢⇩g ⟨r, s⟩ ⇒ t ⟹ r = [Rule m Drop] ⟹ matches γ m p ⟹ s = Undecided ⟹ t = Decision FinalDeny"
by (induction rule: iptables_goto_bigstep.induct) auto
lemma rejectD: "Γ,γ,p⊢⇩g ⟨r, s⟩ ⇒ t ⟹ r = [Rule m Reject] ⟹ matches γ m p ⟹ s = Undecided ⟹ t = Decision FinalDeny"
by (induction rule: iptables_goto_bigstep.induct) auto
lemma logD: "Γ,γ,p⊢⇩g ⟨r, s⟩ ⇒ t ⟹ r = [Rule m Log] ⟹ matches γ m p ⟹ s = Undecided ⟹ t = Undecided"
by (induction rule: iptables_goto_bigstep.induct) auto
lemma emptyD: "Γ,γ,p⊢⇩g ⟨r, s⟩ ⇒ t ⟹ r = [Rule m Empty] ⟹ matches γ m p ⟹ s = Undecided ⟹ t = Undecided"
by (induction rule: iptables_goto_bigstep.induct) auto
lemma nomatchD: "Γ,γ,p⊢⇩g ⟨r, s⟩ ⇒ t ⟹ r = [Rule m a] ⟹ s = Undecided ⟹ ¬ matches γ m p ⟹ t = Undecided"
by (induction rule: iptables_goto_bigstep.induct) auto
lemma callD:
assumes "Γ,γ,p⊢⇩g ⟨r, s⟩ ⇒ t" "r = [Rule m (Call chain)]" "s = Undecided" "matches γ m p" "Γ chain = Some rs"
obtains "Γ,γ,p⊢⇩g ⟨rs,s⟩ ⇒ t"
| rs⇩1 rs⇩2 m' where "rs = rs⇩1 @ Rule m' Return # rs⇩2" "matches γ m' p" "Γ,γ,p⊢⇩g ⟨rs⇩1,s⟩ ⇒ Undecided" "no_matching_Goto γ p rs⇩1" "t = Undecided"
using assms
proof (induction r s t arbitrary: rs rule: iptables_goto_bigstep.induct)
case (seq rs⇩1)
thus ?case by (cases rs⇩1) auto
qed auto
end
private lemmas iptables_goto_bigstepD = skipD acceptD dropD rejectD logD emptyD nomatchD decisionD callD gotoD
private lemma seq':
assumes "rs = rs⇩1 @ rs⇩2" "Γ,γ,p⊢⇩g ⟨rs⇩1,s⟩ ⇒ t" "Γ,γ,p⊢⇩g ⟨rs⇩2,t⟩ ⇒ t'" and "no_matching_Goto γ p rs⇩1"
shows "Γ,γ,p⊢⇩g ⟨rs,s⟩ ⇒ t'"
using assms by (cases s) (auto intro: seq decision dest: decisionD)
private lemma seq'_cons: "Γ,γ,p⊢⇩g ⟨[r],s⟩ ⇒ t ⟹ Γ,γ,p⊢⇩g ⟨rs,t⟩ ⇒ t' ⟹ no_matching_Goto γ p [r] ⟹ Γ,γ,p⊢⇩g ⟨r#rs, s⟩ ⇒ t'"
by (metis decision decisionD state.exhaust seq_cons)
private lemma no_matching_Goto_take: "no_matching_Goto γ p rs ⟹ no_matching_Goto γ p (take n rs)"
apply(induction n arbitrary: rs)
apply(simp_all)
apply(rename_tac r rs)
apply(case_tac rs)
apply(simp_all)
apply(rename_tac r' rs')
apply(case_tac r')
apply(simp)
apply(rename_tac m a)
by(case_tac a) (simp_all)
private lemma seq_split:
assumes "Γ,γ,p⊢⇩g ⟨rs, s⟩ ⇒ t" "rs = rs⇩1@rs⇩2"
obtains (no_matching_Goto) t' where "Γ,γ,p⊢⇩g ⟨rs⇩1,s⟩ ⇒ t'" "Γ,γ,p⊢⇩g ⟨rs⇩2,t'⟩ ⇒ t" "no_matching_Goto γ p rs⇩1"
| (matching_Goto) "Γ,γ,p⊢⇩g ⟨rs⇩1,s⟩ ⇒ t" "¬ no_matching_Goto γ p rs⇩1"
proof -
have "(∃t'. Γ,γ,p⊢⇩g ⟨rs⇩1,s⟩ ⇒ t' ∧ Γ,γ,p⊢⇩g ⟨rs⇩2,t'⟩ ⇒ t ∧ no_matching_Goto γ p rs⇩1) ∨ (Γ,γ,p⊢⇩g ⟨rs⇩1,s⟩ ⇒ t ∧ ¬ no_matching_Goto γ p rs⇩1)"
using assms
proof (induction rs s t arbitrary: rs⇩1 rs⇩2 rule: iptables_goto_bigstep_induct)
case Skip thus ?case by (auto intro: iptables_goto_bigstep.intros simp add: accept)
next
case Allow thus ?case by (cases rs⇩1) (auto intro: iptables_goto_bigstep.intros simp add: accept)
next
case Deny thus ?case by (cases rs⇩1) (auto intro: iptables_goto_bigstep.intros simp add: deny)
next
case Log thus ?case by (cases rs⇩1) (auto intro: iptables_goto_bigstep.intros simp add: log empty)
next
case Nomatch thus ?case by (cases rs⇩1)
(auto intro: iptables_goto_bigstep.intros simp add: not_no_matching_Goto_singleton_cases, meson nomatch not_no_matching_Goto_singleton_cases skip)
next
case Decision thus ?case by (auto intro: iptables_goto_bigstep.intros)
next
case (Seq rs rsa rsb t t')
hence rs: "rsa @ rsb = rs⇩1 @ rs⇩2" by simp
note List.append_eq_append_conv_if[simp]
from rs show ?case
proof (cases rule: list_app_eq_cases)
case longer
with Seq have t1: "Γ,γ,p⊢⇩g ⟨take (length rsa) rs⇩1, Undecided⟩ ⇒ t"
by simp
from Seq.IH(2)[OF longer(2)] have IH:
"(∃t'a. Γ,γ,p⊢⇩g ⟨drop (length rsa) rs⇩1, t⟩ ⇒ t'a ∧ Γ,γ,p⊢⇩g ⟨rs⇩2, t'a⟩ ⇒ t' ∧ no_matching_Goto γ p (drop (length rsa) rs⇩1)) ∨
Γ,γ,p⊢⇩g ⟨drop (length rsa) rs⇩1, t⟩ ⇒ t' ∧ ¬ no_matching_Goto γ p (drop (length rsa) rs⇩1)" (is "?IH_no_Goto ∨ ?IH_Goto") by simp
thus ?thesis
proof(rule disjE)
assume IH: ?IH_no_Goto
from IH obtain t2
where t2a: "Γ,γ,p⊢⇩g ⟨drop (length rsa) rs⇩1,t⟩ ⇒ t2"
and rs_part2: "Γ,γ,p⊢⇩g ⟨rs⇩2,t2⟩ ⇒ t'"
and "no_matching_Goto γ p (drop (length rsa) rs⇩1)"
by blast
with t1 rs_part2 have rs_part1: "Γ,γ,p⊢⇩g ⟨take (length rsa) rs⇩1 @ drop (length rsa) rs⇩1, Undecided⟩ ⇒ t2"
using Seq.hyps(4) longer(1) seq by fastforce
have "no_matching_Goto γ p (take (length rsa) rs⇩1 @ drop (length rsa) rs⇩1)"
using Seq.hyps(4) ‹no_matching_Goto γ p (drop (length rsa) rs⇩1)› longer(1)
no_matching_Goto_append by fastforce
with Seq rs_part1 rs_part2 show ?thesis by auto
next
assume ?IH_Goto
thus ?thesis by (metis Seq.hyps(2) Seq.hyps(4) append_take_drop_id longer(1) no_matching_Goto_append2 seq')
qed
next
case shorter
from shorter rs have rsa': "rsa = rs⇩1 @ take (length rsa - length rs⇩1) rs⇩2"
by (metis append_eq_conv_conj length_drop)
from shorter rs have rsb': "rsb = drop (length rsa - length rs⇩1) rs⇩2"
by (metis append_eq_conv_conj length_drop)
from Seq.hyps(4) rsa' no_matching_Goto_append2 have
no_matching_Goto_rs2: "no_matching_Goto γ p (take (length rsa - length rs⇩1) rs⇩2)" by metis
from rsb' Seq.hyps have t2: "Γ,γ,p⊢⇩g ⟨drop (length rsa - length rs⇩1) rs⇩2,t⟩ ⇒ t'"
by blast
from Seq.IH(1)[OF rsa'] have IH:
"(∃t'. Γ,γ,p⊢⇩g ⟨rs⇩1, Undecided⟩ ⇒ t' ∧ Γ,γ,p⊢⇩g ⟨take (length rsa - length rs⇩1) rs⇩2, t'⟩ ⇒ t ∧ no_matching_Goto γ p rs⇩1) ∨
Γ,γ,p⊢⇩g ⟨rs⇩1, Undecided⟩ ⇒ t ∧ ¬ no_matching_Goto γ p rs⇩1" (is "?IH_no_Goto ∨ ?IH_Goto") by simp
thus ?thesis
proof(rule disjE)
assume IH: ?IH_no_Goto
from IH obtain t1
where t1a: "Γ,γ,p⊢⇩g ⟨rs⇩1,Undecided⟩ ⇒ t1"
and t1b: "Γ,γ,p⊢⇩g ⟨take (length rsa - length rs⇩1) rs⇩2,t1⟩ ⇒ t"
and "no_matching_Goto γ p rs⇩1"
by blast
from no_matching_Goto_rs2 t2 seq' t1b have rs2: "Γ,γ,p⊢⇩g ⟨rs⇩2,t1⟩ ⇒ t'"
by fastforce
from t1a rs2 ‹no_matching_Goto γ p rs⇩1› show ?thesis by fast
next
assume ?IH_Goto
thus ?thesis by (metis Seq.hyps(4) no_matching_Goto_append1 rsa')
qed
qed
next
case Call_return
hence "Γ,γ,p⊢⇩g ⟨rs⇩1, Undecided⟩ ⇒ Undecided" "Γ,γ,p⊢⇩g ⟨rs⇩2, Undecided⟩ ⇒ Undecided"
by (case_tac [!] rs⇩1) (auto intro: iptables_goto_bigstep.skip iptables_goto_bigstep.call_return)
thus ?case by fast
next
case (Call_result _ _ _ _ t)
show ?case
proof (cases rs⇩1)
case Nil
with Call_result have "Γ,γ,p⊢⇩g ⟨rs⇩1, Undecided⟩ ⇒ Undecided" "Γ,γ,p⊢⇩g ⟨rs⇩2, Undecided⟩ ⇒ t"
by (auto intro: iptables_goto_bigstep.intros)
thus ?thesis using local.Nil by auto
next
case Cons
with Call_result have "Γ,γ,p⊢⇩g ⟨rs⇩1, Undecided⟩ ⇒ t" "Γ,γ,p⊢⇩g ⟨rs⇩2, t⟩ ⇒ t"
by (auto intro: iptables_goto_bigstep.intros)
thus ?thesis by fast
qed
next
case (Goto_Decision m a chain rs rest X)
thus ?case
proof (cases rs⇩1)
case Nil
with Goto_Decision have "Γ,γ,p⊢⇩g ⟨rs⇩1, Undecided⟩ ⇒ Undecided" "Γ,γ,p⊢⇩g ⟨rs⇩2, Undecided⟩ ⇒ Decision X"
by (auto intro: iptables_goto_bigstep.intros)
thus ?thesis using local.Nil by auto
next
case Cons
with Goto_Decision have "Γ,γ,p⊢⇩g ⟨rs⇩1, Undecided⟩ ⇒ Decision X" "Γ,γ,p⊢⇩g ⟨rs⇩2, Decision X⟩ ⇒ Decision X"
by (auto intro: iptables_goto_bigstep.intros)
thus ?thesis by fast
qed
next
case (Goto_no_Decision m a chain rs rest rs⇩1)
from Goto_no_Decision have rs1rs2: "Rule m (Goto chain) # rest = rs⇩1 @ rs⇩2" by simp
from goto_no_decision[OF Goto_no_Decision(1)] Goto_no_Decision(3) Goto_no_Decision(4)
have x: "⋀rest. Γ,γ,p⊢⇩g ⟨Rule m (Goto chain) # rest, Undecided⟩ ⇒ Undecided" by simp
show ?case
proof (cases rs⇩1)
case Nil
with Goto_no_Decision have "Γ,γ,p⊢⇩g ⟨rs⇩1, Undecided⟩ ⇒ Undecided" "Γ,γ,p⊢⇩g ⟨rs⇩2, Undecided⟩ ⇒ Undecided"
by (auto intro: iptables_goto_bigstep.intros)
thus ?thesis by fast
next
case (Cons rs⇩1a rs⇩1s)
with rs1rs2 have "rs⇩1 = Rule m (Goto chain) # (take (length rs⇩1s) rest)" by simp
from Cons rs1rs2 have"rs⇩2 = drop (length rs⇩1s) rest" by simp
from Cons Goto_no_Decision have 1: "Γ,γ,p⊢⇩g ⟨rs⇩1, Undecided⟩ ⇒ Undecided"
using x by auto[1]
have 2: "¬ no_matching_Goto γ p rs⇩1"
by (simp add: Goto_no_Decision.hyps(1) ‹rs⇩1 = Rule m (Goto chain) # take (length rs⇩1s) rest›)
from 1 2 show ?thesis by fast
qed
qed
thus ?thesis using matching_Goto no_matching_Goto by blast
qed
private lemma seqE:
assumes "Γ,γ,p⊢⇩g ⟨rs⇩1@rs⇩2, s⟩ ⇒ t"
obtains (no_matching_Goto) ti where "Γ,γ,p⊢⇩g ⟨rs⇩1,s⟩ ⇒ ti" "Γ,γ,p⊢⇩g ⟨rs⇩2,ti⟩ ⇒ t" "no_matching_Goto γ p rs⇩1"
| (matching_Goto) "Γ,γ,p⊢⇩g ⟨rs⇩1,s⟩ ⇒ t" "¬ no_matching_Goto γ p rs⇩1"
using assms by (force elim: seq_split)
private lemma seqE_cons:
assumes "Γ,γ,p⊢⇩g ⟨r#rs, s⟩ ⇒ t"
obtains (no_matching_Goto) ti where "Γ,γ,p⊢⇩g ⟨[r],s⟩ ⇒ ti" "Γ,γ,p⊢⇩g ⟨rs,ti⟩ ⇒ t" "no_matching_Goto γ p [r]"
| (matching_Goto) "Γ,γ,p⊢⇩g ⟨[r],s⟩ ⇒ t" "¬ no_matching_Goto γ p [r]"
using assms by (metis append_Cons append_Nil seqE)
private lemma seqE_cons_Undecided:
assumes "Γ,γ,p⊢⇩g ⟨r#rs, Undecided⟩ ⇒ t"
obtains (no_matching_Goto) ti where "Γ,γ,p⊢⇩g ⟨[r],Undecided⟩ ⇒ ti" and "Γ,γ,p⊢⇩g ⟨rs,ti⟩ ⇒ t" and "no_matching_Goto γ p [r]"
| (matching_Goto) m chain rs' where "r = Rule m (Goto chain)" and "Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)],Undecided⟩ ⇒ t" and "matches γ m p" "Γ chain = Some rs'"
using assms
proof(cases rule: seqE_cons)
case no_matching_Goto thus ?thesis using local.that by simp
next
case matching_Goto
from this(2) not_no_matching_Goto_singleton_cases[of γ p "(get_match r)" "(get_action r)", simplified] have
"((∃chain. (get_action r) = Goto chain) ∧ matches γ (get_match r) p)" by simp
from this obtain chain m where r: "r = Rule m (Goto chain)" "matches γ m p" by(cases r) auto
from matching_Goto r have "Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)],Undecided⟩ ⇒ t" by simp
from gotoD[OF matching_Goto(1)] r ‹matches γ m p› obtain rs' where "Γ chain = Some rs'" by blast
from local.that
show ?thesis using ‹Γ chain = Some rs'› ‹Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)], Undecided⟩ ⇒ t› r(1) r(2) by blast
qed
private lemma nomatch':
assumes "⋀r. r ∈ set rs ⟹ ¬ matches γ (get_match r) p"
shows "Γ,γ,p⊢⇩g ⟨rs, s⟩ ⇒ s"
proof(cases s)
case Undecided
have "∀r∈set rs. ¬ matches γ (get_match r) p ⟹ Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ Undecided"
proof(induction rs)
case Nil
thus ?case by (fast intro: skip)
next
case (Cons r rs)
hence "Γ,γ,p⊢⇩g ⟨[r], Undecided⟩ ⇒ Undecided"
by (cases r) (auto intro: nomatch)
with Cons show ?case
by (metis list.set_intros(1) list.set_intros(2) not_no_matching_Goto_singleton_cases rule.collapse seq'_cons)
qed
with assms Undecided show ?thesis by simp
qed (blast intro: decision)
private lemma no_free_return: assumes "Γ,γ,p⊢⇩g ⟨[Rule m Return], Undecided⟩ ⇒ t" and "matches γ m p" shows "False"
proof -
{ fix a s
have no_free_return_hlp: "Γ,γ,p⊢⇩g ⟨a,s⟩ ⇒ t ⟹ matches γ m p ⟹ s = Undecided ⟹ a = [Rule m Return] ⟹ False"
proof (induction rule: iptables_goto_bigstep.induct)
case (seq rs⇩1)
thus ?case
by (cases rs⇩1) (auto dest: skipD)
qed simp_all
} with assms show ?thesis by blast
qed
subsection‹Determinism›
private lemma iptables_goto_bigstep_Undecided_Undecided_deterministic:
"Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ Undecided ⟹ Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t ⟹ t = Undecided"
proof(induction rs Undecided Undecided arbitrary: t rule: iptables_goto_bigstep_induct)
case Skip thus ?case by(fastforce dest: skipD logD emptyD nomatchD decisionD)
next
case Log thus ?case by(fastforce dest: skipD logD emptyD nomatchD decisionD)
next
case Nomatch thus ?case by(fastforce dest: skipD logD emptyD nomatchD decisionD)
next
case Seq thus ?case by (metis iptables_goto_bigstep_to_undecided seqE)
next
case (Call_return m a chain rs⇩1 m' rs⇩2)
from Call_return have " Γ,γ,p⊢⇩g ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Undecided"
apply(frule_tac rs⇩1=rs⇩1 and m'=m' and chain=chain in call_return)
by(simp_all)
with Call_return show ?case
apply simp
apply (metis callD no_free_return seqE seqE_cons)
done
next
case Call_result thus ?case by (meson callD)
next
case Goto_no_Decision thus ?case by (metis gotoD no_matching_Goto.simps(2) option.sel seqE_cons)
qed
private lemma iptables_goto_bigstep_Undecided_deterministic:
"Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t ⟹ Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t' ⟹ t' = t"
proof(induction rs Undecided t arbitrary: t' rule: iptables_goto_bigstep_induct)
case Skip thus ?case by(fastforce dest: skipD logD emptyD nomatchD decisionD)
next
case Allow thus ?case by (auto dest: iptables_goto_bigstepD)
next
case Deny thus ?case by (auto dest: iptables_goto_bigstepD)
next
case Log thus ?case by (auto dest: iptables_goto_bigstepD)
next
case Nomatch thus ?case by (auto dest: iptables_goto_bigstepD)
next
case Seq thus ?case by (metis decisionD seqE state.exhaust)
next
case Call_return thus ?case by (meson call_return iptables_goto_bigstep_Undecided_Undecided_deterministic)
next
case Call_result thus ?case by (metis callD call_result iptables_goto_bigstep_Undecided_Undecided_deterministic)
next
case Goto_Decision thus ?case by (metis gotoD no_matching_Goto.simps(2) option.sel seqE_cons)
next
case Goto_no_Decision thus ?case by (meson goto_no_decision iptables_goto_bigstep_Undecided_Undecided_deterministic)
qed
qualified theorem iptables_goto_bigstep_deterministic: assumes "Γ,γ,p⊢⇩g ⟨rs, s⟩ ⇒ t" and "Γ,γ,p⊢⇩g ⟨rs, s⟩ ⇒ t'" shows "t = t'"
using assms
apply(cases s)
apply(simp add: iptables_goto_bigstep_Undecided_deterministic)
by(auto dest: decisionD)
subsection‹Matching›
private lemma matches_rule_and_simp_help:
assumes "matches γ m p"
shows "Γ,γ,p⊢⇩g ⟨[Rule (MatchAnd m m') a'], s⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨[Rule m' a'], s⟩ ⇒ t" (is "?l ⟷?r")
proof
assume ?l thus ?r
by (induction "[Rule (MatchAnd m m') a']" s t rule: iptables_goto_bigstep_induct)
(auto intro: iptables_goto_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
next
assume ?r thus ?l
by (induction "[Rule m' a']" s t rule: iptables_goto_bigstep_induct)
(auto intro: iptables_goto_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
qed
private lemma matches_MatchNot_simp:
assumes "matches γ m p"
shows "Γ,γ,p⊢⇩g ⟨[Rule (MatchNot m) a], Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨[], Undecided⟩ ⇒ t" (is "?l ⟷ ?r")
proof
assume ?l thus ?r
by (induction "[Rule (MatchNot m) a]" "Undecided" t rule: iptables_goto_bigstep_induct)
(auto intro: iptables_goto_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
next
assume ?r
hence "t = Undecided"
by (metis skipD)
with assms show ?l
by (fastforce intro: nomatch)
qed
private lemma matches_MatchNotAnd_simp:
assumes "matches γ m p"
shows "Γ,γ,p⊢⇩g ⟨[Rule (MatchAnd (MatchNot m) m') a], Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨[], Undecided⟩ ⇒ t" (is "?l ⟷ ?r")
proof
assume ?l thus ?r
by (induction "[Rule (MatchAnd (MatchNot m) m') a]" "Undecided" t rule: iptables_goto_bigstep_induct)
(auto intro: iptables_goto_bigstep.intros simp add: assms Cons_eq_append_conv dest: skipD)
next
assume ?r
hence "t = Undecided"
by (metis skipD)
with assms show ?l
by (fastforce intro: nomatch)
qed
private lemma matches_rule_and_simp:
assumes "matches γ m p"
shows "Γ,γ,p⊢⇩g ⟨[Rule (MatchAnd m m') a'], s⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨[Rule m' a'], s⟩ ⇒ t"
proof (cases s)
case Undecided
with assms show ?thesis
by (simp add: matches_rule_and_simp_help)
next
case Decision
thus ?thesis by (metis decision decisionD)
qed
qualified definition add_match :: "'a match_expr ⇒ 'a rule list ⇒ 'a rule list" where
"add_match m rs = map (λr. case r of Rule m' a' ⇒ Rule (MatchAnd m m') a') rs"
private lemma add_match_split: "add_match m (rs1@rs2) = add_match m rs1 @ add_match m rs2"
unfolding add_match_def
by (fact map_append)
private lemma add_match_split_fst: "add_match m (Rule m' a' # rs) = Rule (MatchAnd m m') a' # add_match m rs"
unfolding add_match_def
by simp
private lemma matches_add_match_no_matching_Goto_simp: "matches γ m p ⟹ no_matching_Goto γ p (add_match m rs) ⟹ no_matching_Goto γ p rs"
apply(induction rs)
apply(simp_all)
apply(rename_tac r rs)
apply(case_tac r)
apply(simp add: add_match_split_fst no_matching_Goto_tail)
apply(drule no_matching_Goto_head)
apply(rename_tac m' a')
apply(case_tac a')
apply simp_all
done
private lemma matches_add_match_no_matching_Goto_simp2: "matches γ m p ⟹ no_matching_Goto γ p rs ⟹ no_matching_Goto γ p (add_match m rs)"
apply(induction rs)
apply(simp add: add_match_def)
apply(rename_tac r rs)
apply(case_tac r)
apply(simp add: add_match_split_fst no_matching_Goto_tail)
apply(rename_tac m' a')
apply(case_tac a')
apply simp_all
done
private lemma matches_add_match_MatchNot_no_matching_Goto_simp: "¬ matches γ m p ⟹ no_matching_Goto γ p (add_match m rs)"
apply(induction rs)
apply(simp add: add_match_def)
apply(rename_tac r rs)
apply(case_tac r)
apply(simp add: add_match_split_fst no_matching_Goto_tail)
apply(rename_tac m' a')
apply(case_tac a')
apply simp_all
done
private lemma not_matches_add_match_simp:
assumes "¬ matches γ m p"
shows "Γ,γ,p⊢⇩g ⟨add_match m rs, Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨[], Undecided⟩ ⇒ t"
proof(induction rs)
case Nil thus ?case unfolding add_match_def by simp
next
case (Cons r rs)
obtain m' a where r: "r = Rule m' a" by(cases r, simp)
let ?lhs="Γ,γ,p⊢⇩g ⟨Rule (MatchAnd m m') a # add_match m rs, Undecided⟩ ⇒ t"
let ?rhs="Γ,γ,p⊢⇩g ⟨[], Undecided⟩ ⇒ t"
{ assume ?lhs
from ‹?lhs› Cons have ?rhs
proof(cases Γ γ p "Rule (MatchAnd m m') a" "add_match m rs" t rule: seqE_cons_Undecided)
case (no_matching_Goto ti)
hence "ti = Undecided" by (simp add: assms nomatchD)
with no_matching_Goto Cons show ?thesis by simp
next
case (matching_Goto) with Cons assms show ?thesis by force
qed
} note 1=this
{ assume ?rhs
hence "t = Undecided" using skipD by metis
with Cons.IH ‹?rhs› have ?lhs
by (meson assms matches.simps(1) nomatch not_no_matching_Goto_singleton_cases seq_cons)
} with 1 show ?case by(auto simp add: r add_match_split_fst)
qed
private lemma matches_add_match_MatchNot_simp:
assumes m: "matches γ m p"
shows "Γ,γ,p⊢⇩g ⟨add_match (MatchNot m) rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨[], s⟩ ⇒ t" (is "?l s ⟷ ?r s")
proof (cases s)
case Undecided
have "?l Undecided ⟷ ?r Undecided"
proof
assume "?l Undecided" with m show "?r Undecided"
proof (induction rs)
case Nil
thus ?case
unfolding add_match_def by simp
next
case (Cons r rs)
thus ?case
by (cases r) (metis matches_MatchNotAnd_simp skipD seqE_cons add_match_split_fst)
qed
next
assume "?r Undecided" with m show "?l Undecided"
proof (induction rs)
case Nil
thus ?case
unfolding add_match_def by simp
next
case (Cons r rs)
hence "t = Undecided" using skipD by metis
with Cons show ?case
apply (cases r)
apply(simp add: add_match_split_fst)
by (metis matches.simps(1) matches.simps(2) matches_MatchNotAnd_simp not_no_matching_Goto_singleton_cases seq_cons)
qed
qed
with Undecided show ?thesis by fast
next
case (Decision d)
thus ?thesis
by(metis decision decisionD)
qed
private lemma just_show_all_bigstep_semantics_equalities_with_start_Undecided:
"Γ,γ,p⊢⇩g ⟨rs1, Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨rs2, Undecided⟩ ⇒ t ⟹
Γ,γ,p⊢⇩g ⟨rs1, s⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨rs2, s⟩ ⇒ t"
apply(cases s)
apply(simp)
apply(simp)
using decision decisionD by fastforce
private lemma matches_add_match_simp_helper:
assumes m: "matches γ m p"
shows "Γ,γ,p⊢⇩g ⟨add_match m rs, Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t" (is "?l ⟷ ?r")
proof
assume ?l with m show ?r
proof (induction rs)
case Nil
thus ?case
unfolding add_match_def by simp
next
case (Cons r rs)
obtain m' a where r: "r = Rule m' a" by(cases r, simp)
from Cons have " Γ,γ,p⊢⇩g ⟨Rule (MatchAnd m m') a # add_match m rs, Undecided⟩ ⇒ t"
by(simp add: r add_match_split_fst)
from this Cons have "Γ,γ,p⊢⇩g ⟨Rule m' a # rs, Undecided⟩ ⇒ t"
proof(cases rule: seqE_cons_Undecided)
case (no_matching_Goto ti)
from no_matching_Goto(3) Cons.prems(1) not_no_matching_Goto_singleton_cases
have "no_matching_Goto γ p [Rule m' a]" by (metis matches.simps(1))
with no_matching_Goto Cons show ?thesis
apply(simp add: matches_rule_and_simp)
apply(cases ti)
apply (simp add: seq'_cons)
by (metis decision decisionD seq'_cons)
next
case (matching_Goto) with Cons show ?thesis
apply(clarify)
apply(simp add: matches_rule_and_simp_help)
by (simp add: seq_cons_Goto_t)
qed
thus ?case by(simp add: r)
qed
next
assume ?r with m show ?l
proof (induction rs)
case Nil
thus ?case
unfolding add_match_def by simp
next
case (Cons r rs)
obtain m' a where r: "r = Rule m' a" by(cases r, simp)
from Cons have "Γ,γ,p⊢⇩g ⟨Rule m' a # rs, Undecided⟩ ⇒ t" by(simp add: r)
from this have "Γ,γ,p⊢⇩g ⟨Rule (MatchAnd m m') a # add_match m rs, Undecided⟩ ⇒ t"
proof(cases Γ γ p "Rule m' a" rs t rule: seqE_cons_Undecided)
case (no_matching_Goto ti)
from no_matching_Goto Cons.prems matches_rule_and_simp[symmetric] have
"Γ,γ,p⊢⇩g ⟨[Rule (MatchAnd m m') a], Undecided⟩ ⇒ ti" by fast
with Cons.prems Cons.IH no_matching_Goto show ?thesis
apply(cases ti)
apply (metis matches.simps(1) not_no_matching_Goto_singleton_cases seq_cons)
apply (metis decision decisionD matches.simps(1) not_no_matching_Goto_singleton_cases seq_cons)
done
next
case (matching_Goto) with Cons show ?thesis
by (simp add: matches_rule_and_simp_help seq_cons_Goto_t)
qed
thus ?case by(simp add: r add_match_split_fst)
qed
qed
private lemma matches_add_match_simp:
"matches γ m p ⟹ Γ,γ,p⊢⇩g ⟨add_match m rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨rs, s⟩ ⇒ t"
apply(rule just_show_all_bigstep_semantics_equalities_with_start_Undecided)
by(simp add: matches_add_match_simp_helper)
private lemma not_matches_add_matchNot_simp:
"¬ matches γ m p ⟹ Γ,γ,p⊢⇩g ⟨add_match (MatchNot m) rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨rs, s⟩ ⇒ t"
by (simp add: matches_add_match_simp)
subsection‹Goto Unfolding›
private lemma unfold_Goto_Undecided:
assumes chain_defined: "Γ chain = Some rs" and no_matching_Goto_rs: "no_matching_Goto γ p rs"
shows "Γ,γ,p⊢⇩g ⟨(Rule m (Goto chain))#rest, Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨add_match m rs @ add_match (MatchNot m) rest, Undecided⟩ ⇒ t"
(is "?l ⟷ ?r")
proof
assume ?l
thus ?r
proof(cases rule: seqE_cons_Undecided)
case (no_matching_Goto ti)
from no_matching_Goto have "¬ matches γ m p" by simp
with no_matching_Goto have ti: "ti = Undecided" using nomatchD by metis
from ‹¬ matches γ m p› have "Γ,γ,p⊢⇩g ⟨add_match m rs, Undecided⟩ ⇒ Undecided"
using not_matches_add_match_simp skip by fast
from ‹¬ matches γ m p› matches_add_match_MatchNot_no_matching_Goto_simp have "no_matching_Goto γ p (add_match m rs)" by force
from no_matching_Goto ti have "Γ,γ,p⊢⇩g ⟨rest, Undecided⟩ ⇒ t" by simp
with not_matches_add_matchNot_simp[OF ‹¬ matches γ m p›] have "Γ,γ,p⊢⇩g ⟨add_match (MatchNot m) rest, Undecided⟩ ⇒ t" by simp
show ?thesis
by (meson ‹Γ,γ,p⊢⇩g ⟨add_match (MatchNot m) rest, Undecided⟩ ⇒ t› ‹Γ,γ,p⊢⇩g ⟨add_match m rs, Undecided⟩ ⇒ Undecided› ‹no_matching_Goto γ p (add_match m rs)› seq)
next
case (matching_Goto m chain rs')
from matching_Goto gotoD assms have "Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t" by fastforce
hence 1: "Γ,γ,p⊢⇩g ⟨add_match m rs, Undecided⟩ ⇒ t" by (simp add: matches_add_match_simp matching_Goto(3))
have 2: "Γ,γ,p⊢⇩g ⟨add_match (MatchNot m) rest, t⟩ ⇒ t" by (simp add: matches_add_match_MatchNot_simp matching_Goto(3) skip)
from no_matching_Goto_rs matches_add_match_no_matching_Goto_simp2 matching_Goto have 3: "no_matching_Goto γ p (add_match m rs)" by fast
from 1 2 3 show ?thesis using matching_Goto(1) seq by fastforce
qed
next
assume ?r
thus ?l
proof(cases "matches γ m p")
case True
have "Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t"
by (metis True ‹Γ,γ,p⊢⇩g ⟨add_match m rs @ add_match (MatchNot m) rest, Undecided⟩ ⇒ t›
matches_add_match_MatchNot_simp matches_add_match_simp_helper self_append_conv seq' seqE)
show ?l
apply(cases t)
using goto_no_decision[OF True] chain_defined apply (metis ‹Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t›)
using goto_decision[OF True, of Γ chain rs _ rest] chain_defined apply (metis ‹Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t›)
done
next
case False
with ‹?r› have "Γ,γ,p⊢⇩g ⟨add_match (MatchNot m) rest, Undecided⟩ ⇒ t"
by (metis matches_add_match_MatchNot_no_matching_Goto_simp not_matches_add_match_simp seqE skipD)
with False have "Γ,γ,p⊢⇩g ⟨rest, Undecided⟩ ⇒ t" by (meson not_matches_add_matchNot_simp)
show ?l by (meson False ‹Γ,γ,p⊢⇩g ⟨rest, Undecided⟩ ⇒ t› nomatch not_no_matching_Goto_singleton_cases seq_cons)
qed
qed
qualified theorem unfold_Goto:
assumes chain_defined: "Γ chain = Some rs" and no_matching_Goto_rs: "no_matching_Goto γ p rs"
shows "Γ,γ,p⊢⇩g ⟨(Rule m (Goto chain))#rest, s⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨add_match m rs @ add_match (MatchNot m) rest, s⟩ ⇒ t"
apply(rule just_show_all_bigstep_semantics_equalities_with_start_Undecided)
using assms unfold_Goto_Undecided by fast
text‹A chain that will definitely come to a direct decision›
qualified fun terminal_chain :: "'a rule list ⇒ bool" where
"terminal_chain [] = False" |
"terminal_chain [Rule MatchAny Accept] = True" |
"terminal_chain [Rule MatchAny Drop] = True" |
"terminal_chain [Rule MatchAny Reject] = True" |
"terminal_chain ((Rule _ (Goto _))#rs) = False" |
"terminal_chain ((Rule _ (Call _))#rs) = False" |
"terminal_chain ((Rule _ Return)#rs) = False" |
"terminal_chain ((Rule _ Unknown)#rs) = False" |
"terminal_chain (_#rs) = terminal_chain rs"
private lemma terminal_chain_no_matching_Goto: "terminal_chain rs ⟹ no_matching_Goto γ p rs"
by(induction rs rule: terminal_chain.induct) simp_all
text‹A terminal chain means (if the semantics are actually defined) that the chain will
ultimately yield a final filtering decision, for all packets.›
qualified lemma "terminal_chain rs ⟹ Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t ⟹ ∃X. t = Decision X"
apply(induction rs)
apply(simp)
apply(rename_tac r rs)
apply(case_tac r)
apply(rename_tac m a)
apply(simp)
apply(frule_tac γ=γ and p=p in terminal_chain_no_matching_Goto)
apply(case_tac a)
apply(simp_all)
apply(erule seqE_cons, simp_all,
metis iptables_goto_bigstepD matches.elims terminal_chain.simps terminal_chain.simps terminal_chain.simps)+
done
private lemma replace_Goto_with_Call_in_terminal_chain_Undecided:
assumes chain_defined: "Γ chain = Some rs" and terminal_chain: "terminal_chain rs"
shows "Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)], Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨[Rule m (Call chain)], Undecided⟩ ⇒ t"
(is "?l ⟷ ?r")
proof
assume ?l
thus ?r
proof(cases rule: seqE_cons_Undecided)
case (no_matching_Goto ti)
from no_matching_Goto have "¬ matches γ m p" by simp
with nomatch have 1: "Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)], Undecided⟩ ⇒ Undecided" by fast
from ‹¬ matches γ m p› nomatch have 2: "Γ,γ,p⊢⇩g ⟨[Rule m (Call chain)], Undecided⟩ ⇒ Undecided" by fast
from 1 2 show ?thesis
using ‹?l› iptables_goto_bigstep_Undecided_Undecided_deterministic by fastforce
next
case (matching_Goto m chain rs')
from matching_Goto gotoD assms have "Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t" by fastforce
from call_result[OF ‹matches γ m p› chain_defined ‹Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t›] show ?thesis
by (metis matching_Goto(1) rule.sel(1))
qed
next
assume ?r
thus ?l
proof(cases "matches γ m p")
case True
{fix rs1::"'a rule list" and m' and rs2
have "terminal_chain (rs1 @ Rule m' Return # rs2) ⟹ False"
apply(induction rs1)
apply(simp_all)
apply(rename_tac r' rs')
apply(case_tac r')
apply(rename_tac m a)
apply(simp_all)
apply(case_tac a)
apply(simp_all)
apply (metis append_is_Nil_conv hd_Cons_tl terminal_chain.simps)+
done
} note no_return=this
have "Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t"
apply(rule callD[OF ‹?r› _ _ True chain_defined])
apply(simp_all)
using no_return terminal_chain by blast
show ?l
apply(cases t)
using goto_no_decision[OF True] chain_defined apply (metis ‹Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t›)
using goto_decision[OF True, of Γ chain rs _ "[]"] chain_defined apply (metis ‹Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t›)
done
next
case False
show ?l using False ‹Γ,γ,p⊢⇩g ⟨[Rule m (Call chain)], Undecided⟩ ⇒ t› nomatch nomatchD by fastforce
qed
qed
qualified theorem replace_Goto_with_Call_in_terminal_chain:
assumes chain_defined: "Γ chain = Some rs" and terminal_chain: "terminal_chain rs"
shows "Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)], s⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨[Rule m (Call chain)], s⟩ ⇒ t"
apply(rule just_show_all_bigstep_semantics_equalities_with_start_Undecided)
using assms replace_Goto_with_Call_in_terminal_chain_Undecided by fast
qualified fun rewrite_Goto_chain_safe :: "(string ⇀ 'a rule list) ⇒ 'a rule list ⇒ ('a rule list) option" where
"rewrite_Goto_chain_safe _ [] = Some []" |
"rewrite_Goto_chain_safe Γ ((Rule m (Goto chain))#rs) =
(case (Γ chain) of None ⇒ None
| Some rs' ⇒ (if
¬ terminal_chain rs'
then
None
else
map_option (λrs. Rule m (Call chain) # rs) (rewrite_Goto_chain_safe Γ rs)
)
)" |
"rewrite_Goto_chain_safe Γ (r#rs) = map_option (λrs. r # rs) (rewrite_Goto_chain_safe Γ rs)"
private fun rewrite_Goto_safe_internal
:: "(string × 'a rule list) list ⇒ (string × 'a rule list) list ⇒ (string × 'a rule list) list option" where
"rewrite_Goto_safe_internal _ [] = Some []" |
"rewrite_Goto_safe_internal Γ ((chain_name, rs)#cs) =
(case rewrite_Goto_chain_safe (map_of Γ) rs of
None ⇒ None
| Some rs' ⇒ map_option (λrst. (chain_name, rs')#rst) (rewrite_Goto_safe_internal Γ cs)
)"
qualified fun rewrite_Goto_safe :: "(string × 'a rule list) list ⇒ (string × 'a rule list) list option" where
"rewrite_Goto_safe cs = rewrite_Goto_safe_internal cs cs"
qualified definition rewrite_Goto :: "(string × 'a rule list) list ⇒ (string × 'a rule list) list" where
"rewrite_Goto cs = the (rewrite_Goto_safe cs)"
private lemma step_IH_cong: "(⋀s. Γ,γ,p⊢⇩g ⟨rs1, s⟩ ⇒ t = Γ,γ,p⊢⇩g ⟨rs2, s⟩ ⇒ t) ⟹
Γ,γ,p⊢⇩g ⟨r#rs1, s⟩ ⇒ t = Γ,γ,p⊢⇩g ⟨r#rs2, s⟩ ⇒ t"
apply(rule iffI)
apply(erule seqE_cons)
apply(rule seq'_cons)
apply simp_all
apply(drule not_no_matching_Goto_cases)
apply(simp; fail)
apply(elim exE conjE, rename_tac rs1a m chain rs2a)
apply(subgoal_tac "r = Rule m (Goto chain)")
prefer 2
subgoal by (simp add: Cons_eq_append_conv)
apply(thin_tac "[r] = _ @ Rule m (Goto chain) # _")
apply simp
apply (metis decision decisionD seq_cons_Goto_t state.exhaust)
apply(erule seqE_cons)
apply(rule seq'_cons)
apply simp_all
apply(drule not_no_matching_Goto_cases)
apply(simp; fail)
apply(elim exE conjE, rename_tac rs1a m chain rs2a)
apply(subgoal_tac "r = Rule m (Goto chain)")
prefer 2
subgoal by (simp add: Cons_eq_append_conv)
apply(thin_tac "[r] = _ @ Rule m (Goto chain) # _")
apply simp
apply (metis decision decisionD seq_cons_Goto_t state.exhaust)
done
private lemma terminal_chain_decision:
"terminal_chain rs ⟹ Γ,γ,p⊢⇩g ⟨rs, Undecided⟩ ⇒ t ⟹ ∃X. t = Decision X"
apply(induction rs arbitrary: t rule: terminal_chain.induct)
apply simp_all
apply(auto dest: iptables_goto_bigstepD)[3]
apply(erule seqE_cons, simp_all, blast dest: iptables_goto_bigstepD)+
done
private lemma terminal_chain_Goto_decision: "Γ chain = Some rs ⟹ terminal_chain rs ⟹ matches γ m p ⟹
Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)], s⟩ ⇒ t ⟹ ∃X. t = Decision X"
apply(cases s)
apply(drule gotoD, simp_all)
apply(elim exE conjE, simp_all)
using terminal_chain_decision apply fast
by (meson decisionD)
qualified theorem rewrite_Goto_chain_safe:
"rewrite_Goto_chain_safe Γ rs = Some rs' ⟹ Γ,γ,p⊢⇩g ⟨rs', s⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨rs, s⟩ ⇒ t"
proof(induction Γ rs arbitrary: rs' s rule: rewrite_Goto_chain_safe.induct)
case 1 thus ?case by (simp split: option.split_asm if_split_asm)
next
case (2 Γ m chain rs)
from 2(2) obtain z x2 where "Γ chain = Some x2" and "terminal_chain x2"
and "rs' = Rule m (Call chain) # z"
and "Some z = rewrite_Goto_chain_safe Γ rs"
by(auto split: option.split_asm if_split_asm)
from 2(1) ‹Γ chain = Some x2› ‹terminal_chain x2› ‹Some z = rewrite_Goto_chain_safe Γ rs›
have IH: "Γ,γ,p⊢⇩g ⟨z, s⟩ ⇒ t = Γ,γ,p⊢⇩g ⟨rs, s⟩ ⇒ t" for s by simp
have "Γ,γ,p⊢⇩g ⟨Rule m (Call chain) # z, Undecided⟩ ⇒ t ⟷ Γ,γ,p⊢⇩g ⟨Rule m (Goto chain) # rs, Undecided⟩ ⇒ t"
(is "?lhs ⟷ ?rhs")
proof(intro iffI)
assume ?lhs
with IH obtain ti where ti1: "Γ,γ,p⊢⇩g ⟨[Rule m (Call chain)], Undecided⟩ ⇒ ti" and ti2: "Γ,γ,p⊢⇩g ⟨rs, ti⟩ ⇒ t"
by(auto elim: seqE_cons)
show ?rhs
proof(cases "matches γ m p")
case False
from replace_Goto_with_Call_in_terminal_chain ‹Γ chain = Some x2› ‹terminal_chain x2›
have " Γ,γ,p⊢⇩g ⟨[Rule m (Call chain)], Undecided⟩ ⇒ ti ⟷ Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)], Undecided⟩ ⇒ ti"
by fast
with False ti1 ti2 show ?thesis by(rule_tac t=ti in seq'_cons) simp+
next
case True
from ti1 ‹Γ chain = Some x2› ‹terminal_chain x2›
have g: "Γ,γ,p⊢⇩g ⟨[Rule m (Goto chain)], Undecided⟩ ⇒ ti"
by(subst(asm) replace_Goto_with_Call_in_terminal_chain[symmetric]) simp+
with True ‹Γ chain = Some x2› ‹terminal_chain x2› obtain X where X: "ti = Decision X"
by(blast dest: terminal_chain_Goto_decision)
with this ti2 have "t = Decision X"
by(simp add: decisionD)
with g X True ti2 ‹Γ chain = Some x2› ‹terminal_chain x2› show ?thesis
apply(simp)
apply(rule seq_cons_Goto_t, simp_all)
done
qed
next
assume ?rhs
with IH ‹Γ chain = Some x2› ‹terminal_chain x2› ‹Some z = rewrite_Goto_chain_safe Γ rs› show ?lhs
apply -
apply(erule seqE_cons)
subgoal for ti
apply simp_all
apply(rule_tac t=ti in seq'_cons)
apply simp_all
using replace_Goto_with_Call_in_terminal_chain by fast
apply simp
apply(frule(3) terminal_chain_Goto_decision)
apply(subst(asm) replace_Goto_with_Call_in_terminal_chain, simp_all)
apply(rule seq'_cons, simp_all)
apply(elim exE)
by (simp add: decision)
qed
with ‹rs' = Rule m (Call chain) # z› show ?case
apply -
apply(rule just_show_all_bigstep_semantics_equalities_with_start_Undecided)
by simp
qed(auto cong: step_IH_cong)
text‹Example: The semantics are actually defined (for this example).›
lemma defines "γ ≡ (λ_ _. True)" and "m ≡ MatchAny"
shows "[''FORWARD'' ↦ [Rule m Log, Rule m (Call ''foo''), Rule m Drop],
''foo'' ↦ [Rule m Log, Rule m (Goto ''bar''), Rule m Reject],
''bar'' ↦ [Rule m (Goto ''baz''), Rule m Reject],
''baz'' ↦ [(Rule m Accept)]],
γ,p⊢⇩g⟨[Rule MatchAny (Call ''FORWARD'')], Undecided⟩ ⇒ (Decision FinalAllow)"
apply(subgoal_tac "matches γ m p")
prefer 2
apply(simp add: γ_def m_def; fail)
apply(rule call_result)
apply(auto)
apply(rule_tac t=Undecided in seq_cons)
apply(auto intro: log)
apply(rule_tac t="Decision FinalAllow" in seq_cons)
apply(auto intro: decision)
apply(rule call_result)
apply(simp)+
apply(rule_tac t=Undecided in seq_cons)
apply(auto intro: log)
apply(rule goto_decision)
apply(simp)+
apply(rule goto_decision)
apply(simp)+
apply(auto intro: accept)
done
end
end
Theory Negation_Type_DNF
section‹Negation Type DNF›
theory Negation_Type_DNF
imports Negation_Type
begin
type_synonym 'a dnf = "(('a negation_type) list) list"
fun cnf_to_bool :: "('a ⇒ bool) ⇒ 'a negation_type list ⇒ bool" where
"cnf_to_bool _ [] ⟷ True" |
"cnf_to_bool f (Pos a#as) ⟷ (f a) ∧ cnf_to_bool f as" |
"cnf_to_bool f (Neg a#as) ⟷ (¬ f a) ∧ cnf_to_bool f as"
fun dnf_to_bool :: "('a ⇒ bool) ⇒ 'a dnf ⇒ bool" where
"dnf_to_bool _ [] ⟷ False" |
"dnf_to_bool f (as#ass) ⟷ (cnf_to_bool f as) ∨ (dnf_to_bool f ass)"
text‹representing @{const True}›
definition dnf_True :: "'a dnf" where
"dnf_True ≡ [[]]"
lemma dnf_True: "dnf_to_bool f dnf_True"
unfolding dnf_True_def by(simp)
text‹representing @{const False}›
definition dnf_False :: "'a dnf" where
"dnf_False ≡ []"
lemma dnf_False: "¬ dnf_to_bool f dnf_False"
unfolding dnf_False_def by(simp)
lemma cnf_to_bool_append: "cnf_to_bool γ (a1 @ a2) ⟷ cnf_to_bool γ a1 ∧ cnf_to_bool γ a2"
by(induction γ a1 rule: cnf_to_bool.induct) (simp_all)
lemma dnf_to_bool_append: "dnf_to_bool γ (a1 @ a2) ⟷ dnf_to_bool γ a1 ∨ dnf_to_bool γ a2"
by(induction a1) (simp_all)
definition dnf_and :: "'a dnf ⇒ 'a dnf ⇒ 'a dnf" where
"dnf_and cnf1 cnf2 = [andlist1 @ andlist2. andlist1 <- cnf1, andlist2 <- cnf2]"
value "dnf_and ([[a,b], [c,d]]) ([[v,w], [x,y]])"
lemma cnf_to_bool_set: "cnf_to_bool f cnf ⟷ (∀ c ∈ set cnf. (case c of Pos a ⇒ f a | Neg a ⇒ ¬ f a))"
proof(induction cnf)
case Nil thus ?case by simp
next
case Cons thus ?case by (simp split: negation_type.split)
qed
lemma dnf_to_bool_set: "dnf_to_bool γ dnf ⟷ (∃ d ∈ set dnf. cnf_to_bool γ d)"
proof(induction dnf)
case Nil thus ?case by simp
next
case (Cons d d1) thus ?case by(simp)
qed
lemma dnf_to_bool_seteq: "set ` set d1 = set ` set d2 ⟹ dnf_to_bool γ d1 ⟷ dnf_to_bool γ d2"
proof -
assume assm: "set ` set d1 = set ` set d2"
have helper1: "⋀P d. (∃d∈set d. ∀c∈set d. P c) ⟷ (∃d∈set ` set d. ∀c∈d. P c)" by blast
from assm show ?thesis
apply(simp add: dnf_to_bool_set cnf_to_bool_set)
apply(subst helper1)
apply(subst helper1)
apply(simp)
done
qed
lemma dnf_and_correct: "dnf_to_bool γ (dnf_and d1 d2) ⟷ dnf_to_bool γ d1 ∧ dnf_to_bool γ d2"
apply(simp add: dnf_and_def)
apply(induction d1)
apply(simp)
apply(simp add: dnf_to_bool_append)
apply(simp add: dnf_to_bool_set cnf_to_bool_set)
by (meson UnCI UnE)
lemma dnf_and_symmetric: "dnf_to_bool γ (dnf_and d1 d2) ⟷ dnf_to_bool γ (dnf_and d2 d1)"
using dnf_and_correct by blast
subsubsection‹inverting a DNF›
text‹Example›
lemma "(¬ ((a1 ∧ a2) ∨ b ∨ c)) = ((¬a1 ∧ ¬ b ∧ ¬ c) ∨ (¬a2 ∧ ¬ b ∧ ¬ c))" by blast
lemma "(¬ ((a1 ∧ a2) ∨ (b1 ∧ b2) ∨ c)) = ((¬a1 ∧ ¬ b1 ∧ ¬ c) ∨ (¬a2 ∧ ¬ b1 ∧ ¬ c) ∨ (¬a1 ∧ ¬ b2 ∧ ¬ c) ∨ (¬a2 ∧ ¬ b2 ∧ ¬ c))" by blast
fun listprepend :: "'a list ⇒ 'a list list ⇒ 'a list list" where
"listprepend [] ns = []" |
"listprepend (a#as) ns = (map (λxs. a#xs) ns) @ (listprepend as ns)"
lemma "listprepend [a,b] [as, bs] = [a#as, a#bs, b#as, b#bs]" by simp
lemma map_a_and: "dnf_to_bool γ (map ((#) a) ds) ⟷ dnf_to_bool γ [[a]] ∧ dnf_to_bool γ ds"
apply(induction ds)
apply(simp_all)
apply(case_tac a)
apply(simp_all)
apply blast+
done
text‹this is how @{const listprepend} works:›
lemma "¬ dnf_to_bool γ (listprepend [] ds)" by(simp)
lemma "dnf_to_bool γ (listprepend [a] ds) ⟷ dnf_to_bool γ [[a]] ∧ dnf_to_bool γ ds" by(simp add: map_a_and)
lemma "dnf_to_bool γ (listprepend [a, b] ds) ⟷ (dnf_to_bool γ [[a]] ∧ dnf_to_bool γ ds) ∨ (dnf_to_bool γ [[b]] ∧ dnf_to_bool γ ds)"
by(simp add: map_a_and dnf_to_bool_append)
text‹We use ‹∃› to model the big ‹∨› operation›
lemma listprepend_correct: "dnf_to_bool γ (listprepend as ds) ⟷ (∃a∈ set as. dnf_to_bool γ [[a]] ∧ dnf_to_bool γ ds)"
apply(induction as)
apply(simp)
apply(simp)
apply(rename_tac a as)
apply(simp add: map_a_and cnf_to_bool_append dnf_to_bool_append)
by blast
lemma listprepend_correct': "dnf_to_bool γ (listprepend as ds) ⟷ (dnf_to_bool γ (map (λa. [a]) as) ∧ dnf_to_bool γ ds)"
apply(induction as)
apply(simp)
apply(simp)
apply(rename_tac a as)
apply(simp add: map_a_and cnf_to_bool_append dnf_to_bool_append)
by blast
lemma cnf_invert_singelton: "cnf_to_bool γ [invert a] ⟷ ¬ cnf_to_bool γ [a]" by(cases a, simp_all)
lemma cnf_singleton_false: "(∃a'∈set as. ¬ cnf_to_bool γ [a']) ⟷ ¬ cnf_to_bool γ as"
by(induction γ as rule: cnf_to_bool.induct) (simp_all)
fun dnf_not :: "'a dnf ⇒ 'a dnf" where
"dnf_not [] = [[]]" |
"dnf_not (ns#nss) = listprepend (map invert ns) (dnf_not nss)"
lemma dnf_not: "dnf_to_bool γ (dnf_not d) ⟷ ¬ dnf_to_bool γ d"
apply(induction d)
apply(simp_all)
apply(simp add: listprepend_correct)
apply(simp add: cnf_invert_singelton cnf_singleton_false)
done
subsubsection‹Optimizing›
definition optimize_dfn :: "'a dnf ⇒ 'a dnf" where
"optimize_dfn dnf = map remdups (remdups dnf)"
lemma "dnf_to_bool f (optimize_dfn dnf) = dnf_to_bool f dnf"
unfolding optimize_dfn_def
apply(rule dnf_to_bool_seteq)
apply(simp)
by (metis image_cong image_image set_remdups)
end
Theory Matching_Embeddings
theory Matching_Embeddings
imports "Semantics_Ternary/Matching_Ternary" Matching "Semantics_Ternary/Unknown_Match_Tacs"
begin
section‹Boolean Matching vs. Ternary Matching›
term Semantics.matches
term Matching_Ternary.matches
text‹The two matching semantics are related. However, due to the ternary logic, we cannot directly translate one to the other.
The problem are @{const MatchNot} expressions which evaluate to @{const TernaryUnknown} because ‹MatchNot TernaryUnknown› and
‹TernaryUnknown› are semantically equal!›
lemma "∃m β α a. Matching_Ternary.matches (β, α) m a p ≠
Semantics.matches (λ atm p. case β atm p of TernaryTrue ⇒ True | TernaryFalse ⇒ False | TernaryUnknown ⇒ α a p) m p"
apply(rule_tac x="MatchNot (Match X)" in exI)
by (auto split: ternaryvalue.split ternaryvalue.split_asm simp add: matches_case_ternaryvalue_tuple)
text‹the @{const the} in the next definition is always defined›
lemma "∀m ∈ {m. approx m p ≠ TernaryUnknown}. ternary_to_bool (approx m p) ≠ None"
by(simp add: ternary_to_bool_None)
text‹
The Boolean and the ternary matcher agree (where the ternary matcher is defined)
›
definition matcher_agree_on_exact_matches :: "('a, 'p) matcher ⇒ ('a ⇒ 'p ⇒ ternaryvalue) ⇒ bool" where
"matcher_agree_on_exact_matches exact approx ≡ ∀p m. approx m p ≠ TernaryUnknown ⟶ exact m p = the (ternary_to_bool (approx m p))"
text‹We say the Boolean and ternary matchers agree iff they return the same result or the ternary matcher returns @{const TernaryUnknown}.›
lemma "matcher_agree_on_exact_matches exact approx ⟷ (∀p m. exact m p = the (ternary_to_bool (approx m p)) ∨ approx m p = TernaryUnknown)"
unfolding matcher_agree_on_exact_matches_def by blast
lemma matcher_agree_on_exact_matches_alt:
"matcher_agree_on_exact_matches exact approx ⟷ (∀p m. approx m p ≠ TernaryUnknown ⟶ bool_to_ternary (exact m p) = approx m p)"
unfolding matcher_agree_on_exact_matches_def
by (metis (full_types) bool_to_ternary.simps(1) bool_to_ternary.simps(2) option.sel ternary_to_bool.simps(1)
ternary_to_bool.simps(2) ternaryvalue.exhaust)
lemma eval_ternary_Not_TrueD: "eval_ternary_Not m = TernaryTrue ⟹ m = TernaryFalse"
by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
lemma matches_comply_exact: "ternary_ternary_eval (map_match_tac β p m) ≠ TernaryUnknown ⟹
matcher_agree_on_exact_matches γ β ⟹
Semantics.matches γ m p = Matching_Ternary.matches (β, α) m a p"
proof(unfold matches_case_ternaryvalue_tuple,induction m)
case Match thus ?case
by(simp split: ternaryvalue.split add: matcher_agree_on_exact_matches_def)
next
case (MatchNot m) thus ?case
apply(simp split: ternaryvalue.split add: matcher_agree_on_exact_matches_def)
apply(case_tac "ternary_ternary_eval (map_match_tac β p m)")
by(simp_all)
next
case (MatchAnd m1 m2)
thus ?case
apply(case_tac "ternary_ternary_eval (map_match_tac β p m1)")
apply(case_tac [!] "ternary_ternary_eval (map_match_tac β p m2)")
by(simp_all)
next
case MatchAny thus ?case by simp
qed
lemma matcher_agree_on_exact_matches_gammaE:
"matcher_agree_on_exact_matches γ β ⟹ β X p = TernaryTrue ⟹ γ X p"
apply(simp add: matcher_agree_on_exact_matches_alt)
apply(erule_tac x=p in allE)
apply(erule_tac x=X in allE)
apply(simp add: bool_to_ternary_simps)
done
lemma in_doubt_allow_allows_Accept: "a = Accept ⟹ matcher_agree_on_exact_matches γ β ⟹
Semantics.matches γ m p ⟹ Matching_Ternary.matches (β, in_doubt_allow) m a p"
apply(case_tac "ternary_ternary_eval (map_match_tac β p m) ≠ TernaryUnknown")
using matches_comply_exact apply fast
apply(simp add: matches_case_ternaryvalue_tuple)
done
lemma not_exact_match_in_doubt_allow_approx_match: "matcher_agree_on_exact_matches γ β ⟹ a = Accept ∨ a = Reject ∨ a = Drop ⟹
¬ Semantics.matches γ m p ⟹
(a = Accept ∧ Matching_Ternary.matches (β, in_doubt_allow) m a p) ∨ ¬ Matching_Ternary.matches (β, in_doubt_allow) m a p"
apply(case_tac "ternary_ternary_eval (map_match_tac β p m) ≠ TernaryUnknown")
apply(drule(1) matches_comply_exact[where α=in_doubt_allow and a=a])
apply(rule disjI2)
apply fast
apply(simp)
apply(clarify)
apply(simp add: matches_case_ternaryvalue_tuple)
apply(cases a)
apply(simp_all)
done
lemma in_doubt_deny_denies_DropReject: "a = Drop ∨ a = Reject ⟹ matcher_agree_on_exact_matches γ β ⟹
Semantics.matches γ m p ⟹ Matching_Ternary.matches (β, in_doubt_deny) m a p"
apply(case_tac "ternary_ternary_eval (map_match_tac β p m) ≠ TernaryUnknown")
using matches_comply_exact apply fast
apply(simp)
apply(auto simp add: matches_case_ternaryvalue_tuple)
done
lemma not_exact_match_in_doubt_deny_approx_match: "matcher_agree_on_exact_matches γ β ⟹ a = Accept ∨ a = Reject ∨ a = Drop ⟹
¬ Semantics.matches γ m p ⟹
((a = Drop ∨ a = Reject) ∧ Matching_Ternary.matches (β, in_doubt_deny) m a p) ∨ ¬ Matching_Ternary.matches (β, in_doubt_deny) m a p"
apply(case_tac "ternary_ternary_eval (map_match_tac β p m) ≠ TernaryUnknown")
apply(drule(1) matches_comply_exact[where α=in_doubt_deny and a=a])
apply(rule disjI2)
apply fast
apply(simp)
apply(clarify)
apply(simp add: matches_case_ternaryvalue_tuple)
apply(cases a)
apply(simp_all)
done
text‹The ternary primitive matcher can return exactly the result of the Boolean primitive matcher›
definition β⇩m⇩a⇩g⇩i⇩c :: "('a, 'p) matcher ⇒ ('a ⇒ 'p ⇒ ternaryvalue)" where
"β⇩m⇩a⇩g⇩i⇩c γ ≡ (λ a p. if γ a p then TernaryTrue else TernaryFalse)"
lemma "matcher_agree_on_exact_matches γ (β⇩m⇩a⇩g⇩i⇩c γ)"
by(simp add: matcher_agree_on_exact_matches_def β⇩m⇩a⇩g⇩i⇩c_def)
lemma β⇩m⇩a⇩g⇩i⇩c_not_Unknown: "ternary_ternary_eval (map_match_tac (β⇩m⇩a⇩g⇩i⇩c γ) p m) ≠ TernaryUnknown"
proof(induction m)
case MatchNot thus ?case using eval_ternary_Not_UnknownD β⇩m⇩a⇩g⇩i⇩c_def
by (simp) blast
case (MatchAnd m1 m2) thus ?case
apply(case_tac "ternary_ternary_eval (map_match_tac (β⇩m⇩a⇩g⇩i⇩c γ) p m1)")
apply(case_tac [!] "ternary_ternary_eval (map_match_tac (β⇩m⇩a⇩g⇩i⇩c γ) p m2)")
by(simp_all add: β⇩m⇩a⇩g⇩i⇩c_def)
qed (simp_all add: β⇩m⇩a⇩g⇩i⇩c_def)
lemma β⇩m⇩a⇩g⇩i⇩c_matching: "Matching_Ternary.matches ((β⇩m⇩a⇩g⇩i⇩c γ), α) m a p ⟷ Semantics.matches γ m p"
proof(induction m)
case Match thus ?case
by(simp add: β⇩m⇩a⇩g⇩i⇩c_def matches_case_ternaryvalue_tuple)
case MatchNot thus ?case
by(simp add: matches_case_ternaryvalue_tuple β⇩m⇩a⇩g⇩i⇩c_not_Unknown split: ternaryvalue.split_asm)
qed (simp_all add: matches_case_ternaryvalue_tuple split: ternaryvalue.split ternaryvalue.split_asm)
end
Theory Fixed_Action
theory Fixed_Action
imports Semantics_Ternary
begin
section‹Fixed Action›
text‹If firewall rules have the same action, we can focus on the matching only.›
text‹Applying a rule once or several times makes no difference.›
lemma approximating_bigstep_fun_prepend_replicate:
"n > 0 ⟹ approximating_bigstep_fun γ p (r#rs) Undecided = approximating_bigstep_fun γ p ((replicate n r)@rs) Undecided"
apply(induction n)
apply(simp)
apply(simp)
apply(case_tac r)
apply(rename_tac m a)
apply(simp split: action.split)
by fastforce
text‹utility lemmas›
context
begin
private lemma fixedaction_Log: "approximating_bigstep_fun γ p (map (λm. Rule m Log) ms) Undecided = Undecided"
by(induction ms, simp_all)
private lemma fixedaction_Empty:"approximating_bigstep_fun γ p (map (λm. Rule m Empty) ms) Undecided = Undecided"
by(induction ms, simp_all)
private lemma helperX1_Log: "matches γ m' Log p ⟹
approximating_bigstep_fun γ p (map ((λm. Rule m Log) ∘ MatchAnd m') m2' @ rs2) Undecided =
approximating_bigstep_fun γ p rs2 Undecided"
by(induction m2')(simp_all split: action.split)
private lemma helperX1_Empty: "matches γ m' Empty p ⟹
approximating_bigstep_fun γ p (map ((λm. Rule m Empty) ∘ MatchAnd m') m2' @ rs2) Undecided =
approximating_bigstep_fun γ p rs2 Undecided"
by(induction m2')(simp_all split: action.split)
private lemma helperX3: "matches γ m' a p ⟹
approximating_bigstep_fun γ p (map ((λm. Rule m a) ∘ MatchAnd m') m2' @ rs2 ) Undecided =
approximating_bigstep_fun γ p (map (λm. Rule m a) m2' @ rs2) Undecided"
proof(induction m2')
case Nil thus ?case by simp
next
case Cons thus ?case by(cases a) (simp_all add: matches_simps)
qed
lemmas fixed_action_simps = fixedaction_Log fixedaction_Empty helperX1_Log helperX1_Empty helperX3
end
lemma fixedaction_swap:
"approximating_bigstep_fun γ p (map (λm. Rule m a) (m1@m2)) s = approximating_bigstep_fun γ p (map (λm. Rule m a) (m2@m1)) s"
proof(induction s rule: just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
case Undecided
have "approximating_bigstep_fun γ p (map (λm. Rule m a) m1 @ map (λm. Rule m a) m2) Undecided =
approximating_bigstep_fun γ p (map (λm. Rule m a) m2 @ map (λm. Rule m a) m1) Undecided"
proof(induction m1)
case Nil thus ?case by simp
next
case (Cons m m1)
{ fix m rs
have "approximating_bigstep_fun γ p ((map (λm. Rule m Log) m)@rs) Undecided =
approximating_bigstep_fun γ p rs Undecided"
by(induction m) (simp_all)
} note Log_helper=this
{ fix m rs
have "approximating_bigstep_fun γ p ((map (λm. Rule m Empty) m)@rs) Undecided =
approximating_bigstep_fun γ p rs Undecided"
by(induction m) (simp_all)
} note Empty_helper=this
show ?case
proof(cases "matches γ m a p")
case True
thus ?thesis
proof(induction m2)
case Nil thus ?case by simp
next
case Cons thus ?case
apply(simp split:action.split action.split_asm)
using Log_helper Empty_helper by fastforce+
qed
next
case False
thus ?thesis
apply(simp)
apply(simp add: Cons.IH)
apply(induction m2)
apply(simp_all)
apply(simp split:action.split action.split_asm)
apply fastforce
done
qed
qed
thus ?thesis using Undecided by simp
qed
corollary fixedaction_reorder: "approximating_bigstep_fun γ p (map (λm. Rule m a) (m1 @ m2 @ m3)) s = approximating_bigstep_fun γ p (map (λm. Rule m a) (m2 @ m1 @ m3)) s"
proof(induction s rule: just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
case Undecided
have "approximating_bigstep_fun γ p (map (λm. Rule m a) (m1 @ m2 @ m3)) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) (m2 @ m1 @ m3)) Undecided"
proof(induction m3)
case Nil thus ?case using fixedaction_swap by fastforce
next
case (Cons m3'1 m3)
have "approximating_bigstep_fun γ p (map (λm. Rule m a) ((m3'1 # m3) @ m1 @ m2)) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) ((m3'1 # m3) @ m2 @ m1)) Undecided"
apply(simp)
apply(cases "matches γ m3'1 a p")
apply(simp split: action.split action.split_asm)
apply (metis append_assoc fixedaction_swap map_append Cons.IH)
apply(simp)
by (metis append_assoc fixedaction_swap map_append Cons.IH)
hence "approximating_bigstep_fun γ p (map (λm. Rule m a) ((m1 @ m2) @ m3'1 # m3)) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) ((m2 @ m1) @ m3'1 # m3)) Undecided"
apply(subst fixedaction_swap)
apply(subst(2) fixedaction_swap)
by simp
thus ?case
apply(subst append_assoc[symmetric])
apply(subst append_assoc[symmetric])
by simp
qed
thus ?thesis using Undecided by simp
qed
text‹If the actions are equal, the @{term set} (position and replication independent) of the match expressions can be considered.›
lemma approximating_bigstep_fun_fixaction_matchseteq: "set m1 = set m2 ⟹
approximating_bigstep_fun γ p (map (λm. Rule m a) m1) s =
approximating_bigstep_fun γ p (map (λm. Rule m a) m2) s"
proof(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
assume m1m2_seteq: "set m1 = set m2" and "s = Undecided"
from m1m2_seteq have
"approximating_bigstep_fun γ p (map (λm. Rule m a) m1) Undecided =
approximating_bigstep_fun γ p (map (λm. Rule m a) m2) Undecided"
proof(induction m1 arbitrary: m2)
case Nil thus ?case by simp
next
case (Cons m m1)
show ?case
proof (cases "m ∈ set m1")
case True
from True have "set m1 = set (m # m1)" by auto
from Cons.IH[OF ‹set m1 = set (m # m1)›] have "approximating_bigstep_fun γ p (map (λm. Rule m a) (m # m1)) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) (m1)) Undecided" ..
thus ?thesis by (metis Cons.IH Cons.prems ‹set m1 = set (m # m1)›)
next
case False
from False have "m ∉ set m1" .
show ?thesis
proof (cases "m ∉ set m2")
case True
from True ‹m ∉ set m1› Cons.prems have "set m1 = set m2" by auto
from Cons.IH[OF this] show ?thesis by (metis Cons.IH Cons.prems ‹set m1 = set m2›)
next
case False
hence "m ∈ set m2" by simp
have repl_filter_simp: "(replicate (length [x←m2 . x = m]) m) = [x←m2 . x = m]"
by (metis (lifting, full_types) filter_set member_filter replicate_length_same)
from Cons.prems ‹m ∉ set m1› have "set m1 = set (filter (λx. x≠m) m2)" by auto
from Cons.IH[OF this] have "approximating_bigstep_fun γ p (map (λm. Rule m a) m1) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) [x←m2 . x ≠ m]) Undecided" .
from this have "approximating_bigstep_fun γ p (map (λm. Rule m a) (m#m1)) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) (m#[x←m2 . x ≠ m])) Undecided"
apply(simp split: action.split)
by fast
also have "… = approximating_bigstep_fun γ p (map (λm. Rule m a) ([x←m2 . x = m]@[x←m2 . x ≠ m])) Undecided"
apply(simp only: list.map)
thm approximating_bigstep_fun_prepend_replicate[where n="length [x←m2 . x = m]"]
apply(subst approximating_bigstep_fun_prepend_replicate[where n="length [x←m2 . x = m]"])
apply (metis (full_types) False filter_empty_conv neq0_conv repl_filter_simp replicate_0)
by (metis (lifting, no_types) map_append map_replicate repl_filter_simp)
also have "… = approximating_bigstep_fun γ p (map (λm. Rule m a) m2) Undecided"
proof(induction m2)
case Nil thus ?case by simp
next
case(Cons m2'1 m2')
have "approximating_bigstep_fun γ p (map (λm. Rule m a) [x←m2' . x = m] @ Rule m2'1 a # map (λm. Rule m a) [x←m2' . x ≠ m]) Undecided =
approximating_bigstep_fun γ p (map (λm. Rule m a) ([x←m2' . x = m] @ [m2'1] @ [x←m2' . x ≠ m])) Undecided" by fastforce
also have "… = approximating_bigstep_fun γ p (map (λm. Rule m a) ([m2'1] @ [x←m2' . x = m] @ [x←m2' . x ≠ m])) Undecided"
using fixedaction_reorder by fast
finally have XX: "approximating_bigstep_fun γ p (map (λm. Rule m a) [x←m2' . x = m] @ Rule m2'1 a # map (λm. Rule m a) [x←m2' . x ≠ m]) Undecided =
approximating_bigstep_fun γ p (Rule m2'1 a # (map (λm. Rule m a) [x←m2' . x = m] @ map (λm. Rule m a) [x←m2' . x ≠ m])) Undecided"
by fastforce
from Cons show ?case
apply(case_tac "m2'1 = m")
apply(simp split: action.split)
apply fast
apply(simp del: approximating_bigstep_fun.simps)
apply(simp only: XX)
apply(case_tac "matches γ m2'1 a p")
apply(simp)
apply(simp split: action.split)
apply(fast)
apply(simp)
done
qed
finally show ?thesis .
qed
qed
qed
thus ?thesis using ‹s = Undecided› by simp
qed
subsection‹@{term match_list}›
text‹Reducing the firewall semantics to short-circuit matching evaluation›
fun match_list :: "('a, 'packet) match_tac ⇒ 'a match_expr list ⇒ action ⇒ 'packet ⇒ bool" where
"match_list γ [] a p = False" |
"match_list γ (m#ms) a p = (if matches γ m a p then True else match_list γ ms a p)"
lemma match_list_matches: "match_list γ ms a p ⟷ (∃m ∈ set ms. matches γ m a p)"
by(induction ms, simp_all)
lemma match_list_True: "match_list γ ms a p ⟹ approximating_bigstep_fun γ p (map (λm. Rule m a) ms) Undecided = (case a of Accept ⇒ Decision FinalAllow
| Drop ⇒ Decision FinalDeny
| Reject ⇒ Decision FinalDeny
| Log ⇒ Undecided
| Empty ⇒ Undecided
)"
apply(induction ms)
apply(simp)
apply(simp split: if_split_asm action.split)
apply(simp add: fixed_action_simps)
done
lemma match_list_False: "¬ match_list γ ms a p ⟹ approximating_bigstep_fun γ p (map (λm. Rule m a) ms) Undecided = Undecided"
apply(induction ms)
apply(simp)
apply(simp split: if_split_asm action.split)
done
text‹The key idea behind @{const match_list}: Reducing semantics to match list›
lemma match_list_semantics: "match_list γ ms1 a p ⟷ match_list γ ms2 a p ⟹
approximating_bigstep_fun γ p (map (λm. Rule m a) ms1) s = approximating_bigstep_fun γ p (map (λm. Rule m a) ms2) s"
apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
apply(simp)
apply(thin_tac "s = Undecided")
apply(induction ms2)
apply(simp)
apply(induction ms1)
apply(simp)
apply(simp split: if_split_asm)
apply(rename_tac m ms2)
apply(simp del: approximating_bigstep_fun.simps)
apply(simp split: if_split_asm del: approximating_bigstep_fun.simps)
apply(simp split: action.split add: match_list_True fixed_action_simps)
apply(simp)
done
text‹We can exploit de-morgan to get a disjunction in the match expression!›
fun match_list_to_match_expr :: "'a match_expr list ⇒ 'a match_expr" where
"match_list_to_match_expr [] = MatchNot MatchAny" |
"match_list_to_match_expr (m#ms) = MatchOr m (match_list_to_match_expr ms)"
text‹@{const match_list_to_match_expr} constructs a unwieldy @{typ "'a match_expr"} from a list.
The semantics of the resulting match expression is the disjunction of the elements of the list.
This is handy because the normal match expressions do not directly support disjunction.
Use this function with care because the resulting match expression is very ugly!›
lemma match_list_to_match_expr_disjunction: "match_list γ ms a p ⟷ matches γ (match_list_to_match_expr ms) a p"
apply(induction ms rule: match_list_to_match_expr.induct)
apply(simp add: bunch_of_lemmata_about_matches; fail)
apply(simp add: MatchOr)
done
lemma match_list_singleton: "match_list γ [m] a p ⟷ matches γ m a p" by(simp)
lemma match_list_append: "match_list γ (m1@m2) a p ⟷ (¬ match_list γ m1 a p ⟶ match_list γ m2 a p)"
by(induction m1) simp+
lemma match_list_helper1: "¬ matches γ m2 a p ⟹ match_list γ (map (λx. MatchAnd x m2) m1') a p ⟹ False"
apply(induction m1')
apply(simp; fail)
apply(simp split:if_split_asm)
by(auto dest: matches_dest)
lemma match_list_helper2: " ¬ matches γ m a p ⟹ ¬ match_list γ (map (MatchAnd m) m2') a p"
apply(induction m2')
apply(simp; fail)
apply(simp split:if_split_asm)
by(auto dest: matches_dest)
lemma match_list_helper3: "matches γ m a p ⟹ match_list γ m2' a p ⟹ match_list γ (map (MatchAnd m) m2') a p"
apply(induction m2')
apply(simp; fail)
apply(simp split:if_split_asm)
by (simp add: matches_simps)
lemma match_list_helper4: "¬ match_list γ m2' a p ⟹ ¬ match_list γ (map (MatchAnd aa) m2') a p "
apply(induction m2')
apply(simp; fail)
apply(simp split:if_split_asm)
by(auto dest: matches_dest)
lemma match_list_helper5: " ¬ match_list γ m2' a p ⟹ ¬ match_list γ (concat (map (λx. map (MatchAnd x) m2') m1')) a p "
apply(induction m2')
apply(simp add:empty_concat; fail)
apply(simp split:if_split_asm)
apply(induction m1')
apply(simp; fail)
apply(simp add: match_list_append)
by(auto dest: matches_dest)
lemma match_list_helper6: "¬ match_list γ m1' a p ⟹ ¬ match_list γ (concat (map (λx. map (MatchAnd x) m2') m1')) a p "
apply(induction m2')
apply(simp add:empty_concat; fail)
apply(simp split:if_split_asm)
apply(induction m1')
apply(simp; fail)
apply(simp add: match_list_append split: if_split_asm)
by(auto dest: matches_dest)
lemmas match_list_helper = match_list_helper1 match_list_helper2 match_list_helper3 match_list_helper4 match_list_helper5 match_list_helper6
hide_fact match_list_helper1 match_list_helper2 match_list_helper3 match_list_helper4 match_list_helper5 match_list_helper6
lemma match_list_map_And1: "matches γ m1 a p = match_list γ m1' a p ⟹
matches γ (MatchAnd m1 m2) a p ⟷ match_list γ (map (λx. MatchAnd x m2) m1') a p"
apply(induction m1')
apply(auto dest: matches_dest; fail)[1]
apply(simp split: if_split_asm)
apply safe
apply(simp_all add: matches_simps)
apply(auto dest: match_list_helper(1))[1]
by(auto dest: matches_dest)
lemma matches_list_And_concat: "matches γ m1 a p = match_list γ m1' a p ⟹ matches γ m2 a p = match_list γ m2' a p ⟹
matches γ (MatchAnd m1 m2) a p ⟷ match_list γ [MatchAnd x y. x <- m1', y <- m2'] a p"
apply(induction m1')
apply(auto dest: matches_dest; fail)[1]
apply(simp split: if_split_asm)
prefer 2
apply(simp add: match_list_append)
apply(subgoal_tac "¬ match_list γ (map (MatchAnd aa) m2') a p")
apply(simp; fail)
apply safe
apply(simp_all add: matches_simps match_list_append match_list_helper)
done
lemma match_list_concat: "match_list γ (concat lss) a p ⟷ (∃ls ∈ set lss. match_list γ ls a p)"
apply(induction lss)
apply(simp; fail)
by(auto simp add: match_list_append)
lemma fixedaction_wf_ruleset: "wf_ruleset γ p (map (λm. Rule m a) ms) ⟷
¬ match_list γ ms a p ∨ ¬ (∃chain. a = Call chain) ∧ a ≠ Return ∧ ¬ (∃chain. a = Goto chain) ∧ a ≠ Unknown"
proof -
have helper: "⋀a b c. a ⟷ c ⟹ (a ⟶ b) = (c ⟶ b)" by fast
show ?thesis
apply(simp add: wf_ruleset_def)
apply(rule helper)
apply(induction ms)
apply(simp; fail)
apply(simp)
done
qed
lemma wf_ruleset_singleton: "wf_ruleset γ p [Rule m a] ⟷ ¬ matches γ m a p ∨ ¬ (∃chain. a = Call chain) ∧ a ≠ Return ∧ ¬ (∃chain. a = Goto chain) ∧ a ≠ Unknown"
by(simp add: wf_ruleset_def)
end
Theory Normalized_Matches
theory Normalized_Matches
imports Fixed_Action
begin
section‹Normalized (DNF) matches›
text‹simplify a match expression. The output is a list of match exprissions, the semantics is ‹∨› of the list elements.›
fun normalize_match :: "'a match_expr ⇒ 'a match_expr list" where
"normalize_match (MatchAny) = [MatchAny]" |
"normalize_match (Match m) = [Match m]" |
"normalize_match (MatchAnd m1 m2) = [MatchAnd x y. x <- normalize_match m1, y <- normalize_match m2]" |
"normalize_match (MatchNot (MatchAnd m1 m2)) = normalize_match (MatchNot m1) @ normalize_match (MatchNot m2)" |
"normalize_match (MatchNot (MatchNot m)) = normalize_match m" |
"normalize_match (MatchNot (MatchAny)) = []" |
"normalize_match (MatchNot (Match m)) = [MatchNot (Match m)]"
lemma normalize_match_not_matcheq_matchNone: "∀m' ∈ set (normalize_match m). ¬ matcheq_matchNone m'"
proof(induction m rule: normalize_match.induct)
case 4 thus ?case by (simp) blast
qed(simp_all)
lemma normalize_match_empty_iff_matcheq_matchNone: "normalize_match m = [] ⟷ matcheq_matchNone m "
proof(induction m rule: normalize_match.induct)
case 3 thus ?case by (simp) fastforce
qed(simp_all)
lemma match_list_normalize_match: "match_list γ [m] a p ⟷ match_list γ (normalize_match m) a p"
proof(induction m rule:normalize_match.induct)
case 1 thus ?case by(simp add: match_list_singleton)
next
case 2 thus ?case by(simp add: match_list_singleton)
next
case (3 m1 m2) thus ?case
apply(simp_all add: match_list_singleton del: match_list.simps(2))
apply(case_tac "matches γ m1 a p")
apply(rule matches_list_And_concat)
apply(simp)
apply(case_tac "(normalize_match m1)")
apply simp
apply (auto)[1]
apply(simp add: bunch_of_lemmata_about_matches match_list_helper)
done
next
case 4 thus ?case
apply(simp_all add: match_list_singleton del: match_list.simps(2))
apply(simp add: match_list_append)
apply(safe)
apply(simp_all add: matches_DeMorgan)
done
next
case 5 thus ?case
by(simp add: match_list_singleton bunch_of_lemmata_about_matches)
next
case 6 thus ?case
by(simp add: match_list_singleton bunch_of_lemmata_about_matches)
next
case 7 thus ?case by(simp add: match_list_singleton)
qed
thm match_list_normalize_match[simplified match_list_singleton]
theorem normalize_match_correct: "approximating_bigstep_fun γ p (map (λm. Rule m a) (normalize_match m)) s = approximating_bigstep_fun γ p [Rule m a] s"
apply(rule match_list_semantics[of _ _ _ _ "[m]", simplified])
using match_list_normalize_match by fastforce
lemma normalize_match_empty: "normalize_match m = [] ⟹ ¬ matches γ m a p"
proof(induction m rule: normalize_match.induct)
case 3 thus ?case by(fastforce dest: matches_dest)
next
case 4 thus ?case using match_list_normalize_match by (simp add: matches_DeMorgan)
next
case 5 thus ?case using matches_not_idem by fastforce
next
case 6 thus ?case by(simp add: bunch_of_lemmata_about_matches)
qed(simp_all)
lemma matches_to_match_list_normalize: "matches γ m a p = match_list γ (normalize_match m) a p"
using match_list_normalize_match[simplified match_list_singleton] .
lemma wf_ruleset_normalize_match: "wf_ruleset γ p [(Rule m a)] ⟹ wf_ruleset γ p (map (λm. Rule m a) (normalize_match m))"
proof(induction m rule: normalize_match.induct)
case 1 thus ?case by simp
next
case 2 thus ?case by simp
next
case 3 thus ?case by(simp add: fixedaction_wf_ruleset wf_ruleset_singleton matches_to_match_list_normalize)
next
case 4 thus ?case
apply(simp add: wf_ruleset_append)
apply(simp add: fixedaction_wf_ruleset)
apply(unfold wf_ruleset_singleton)
apply(safe)
apply(simp_all add: matches_to_match_list_normalize)
apply(simp_all add: match_list_append)
done
next
case 5 thus ?case by(simp add: wf_ruleset_singleton matches_to_match_list_normalize)
next
case 6 thus ?case by(simp add: wf_ruleset_def)
next
case 7 thus ?case by(simp_all add: wf_ruleset_append)
qed
lemma normalize_match_wf_ruleset: "wf_ruleset γ p (map (λm. Rule m a) (normalize_match m)) ⟹ wf_ruleset γ p [Rule m a]"
proof(induction m rule: normalize_match.induct)
case 1 thus ?case by simp
next
case 2 thus ?case by simp
next
case 3 thus ?case by(simp add: fixedaction_wf_ruleset wf_ruleset_singleton matches_to_match_list_normalize)
next
case 4 thus ?case
apply(simp add: wf_ruleset_append)
apply(simp add: fixedaction_wf_ruleset)
apply(unfold wf_ruleset_singleton)
apply(safe)
apply(simp_all add: matches_to_match_list_normalize)
apply(simp_all add: match_list_append)
done
next
case 5 thus ?case
unfolding wf_ruleset_singleton by(simp add: matches_to_match_list_normalize)
next
case 6 thus ?case unfolding wf_ruleset_singleton by(simp add: bunch_of_lemmata_about_matches)
next
case 7 thus ?case by(simp add: wf_ruleset_append)
qed
lemma good_ruleset_normalize_match: "good_ruleset [(Rule m a)] ⟹ good_ruleset (map (λm. Rule m a) (normalize_match m))"
by(simp add: good_ruleset_def)
section‹Normalizing rules instead of only match expressions›
fun normalize_rules :: "('a match_expr ⇒ 'a match_expr list) ⇒ 'a rule list ⇒ 'a rule list" where
"normalize_rules _ [] = []" |
"normalize_rules f ((Rule m a)#rs) = (map (λm. Rule m a) (f m))@(normalize_rules f rs)"
lemma normalize_rules_singleton: "normalize_rules f [Rule m a] = map (λm. Rule m a) (f m)" by(simp)
lemma normalize_rules_fst: "(normalize_rules f (r # rs)) = (normalize_rules f [r]) @ (normalize_rules f rs)"
by(cases r) (simp)
lemma normalize_rules_concat_map:
"normalize_rules f rs = concat (map (λr. map (λm. Rule m (get_action r)) (f (get_match r))) rs)"
apply(induction rs)
apply(simp_all)
apply(rename_tac r rs, case_tac r)
apply(simp)
done
lemma good_ruleset_normalize_rules: "good_ruleset rs ⟹ good_ruleset (normalize_rules f rs)"
proof(induction rs)
case Nil thus ?case by (simp)
next
case(Cons r rs)
from Cons have IH: "good_ruleset (normalize_rules f rs)" using good_ruleset_tail by blast
from Cons.prems have "good_ruleset [r]" using good_ruleset_fst by fast
hence "good_ruleset (normalize_rules f [r])" by(cases r) (simp add: good_ruleset_alt)
with IH good_ruleset_append have "good_ruleset (normalize_rules f [r] @ normalize_rules f rs)" by blast
thus ?case using normalize_rules_fst by metis
qed
lemma simple_ruleset_normalize_rules: "simple_ruleset rs ⟹ simple_ruleset (normalize_rules f rs)"
proof(induction rs)
case Nil thus ?case by (simp)
next
case(Cons r rs)
from Cons have IH: "simple_ruleset (normalize_rules f rs)" using simple_ruleset_tail by blast
from Cons.prems have "simple_ruleset [r]" using simple_ruleset_append by fastforce
hence "simple_ruleset (normalize_rules f [r])" by(cases r) (simp add: simple_ruleset_def)
with IH simple_ruleset_append have "simple_ruleset (normalize_rules f [r] @ normalize_rules f rs)" by blast
thus ?case using normalize_rules_fst by metis
qed
lemma normalize_rules_match_list_semantics_3:
assumes "∀m a. P m ⟶ match_list γ (f m) a p = matches γ m a p"
and "simple_ruleset rs"
and P: "∀ r ∈ set rs. P (get_match r)"
shows "approximating_bigstep_fun γ p (normalize_rules f rs) s = approximating_bigstep_fun γ p rs s"
proof -
have assm_1: "∀r∈set rs. match_list γ (f (get_match r)) (get_action r) p = matches γ (get_match r) (get_action r) p" using P assms(1) by blast
{ fix r s
assume "r ∈ set rs"
with assm_1 have "match_list γ (f (get_match r)) (get_action r) p ⟷ match_list γ [(get_match r)] (get_action r) p" by simp
with match_list_semantics[of γ "f (get_match r)" "(get_action r)" p "[(get_match r)]"] have
"approximating_bigstep_fun γ p (map (λm. Rule m (get_action r)) (f (get_match r))) s =
approximating_bigstep_fun γ p [Rule (get_match r) (get_action r)] s" by simp
hence "(approximating_bigstep_fun γ p (normalize_rules f [r]) s) = approximating_bigstep_fun γ p [r] s"
by(cases r) (simp)
}
with assms show ?thesis
proof(induction rs arbitrary: s)
case Nil thus ?case by (simp)
next
case (Cons r rs)
from Cons.prems have "simple_ruleset [r]" by(simp add: simple_ruleset_def)
with simple_imp_good_ruleset good_imp_wf_ruleset have wf_r: "wf_ruleset γ p [r]" by fast
from ‹simple_ruleset [r]› simple_imp_good_ruleset good_imp_wf_ruleset have wf_r:
"wf_ruleset γ p [r]" by fast
from simple_ruleset_normalize_rules[OF ‹simple_ruleset [r]›] have "simple_ruleset (normalize_rules f [r])"
by(simp)
with simple_imp_good_ruleset good_imp_wf_ruleset have wf_nr: "wf_ruleset γ p (normalize_rules f [r])" by fast
from Cons have IH: "⋀s. approximating_bigstep_fun γ p (normalize_rules f rs) s = approximating_bigstep_fun γ p rs s"
using simple_ruleset_tail by force
from Cons have a: "⋀s. approximating_bigstep_fun γ p (normalize_rules f [r]) s = approximating_bigstep_fun γ p [r] s" by simp
show ?case
apply(subst normalize_rules_fst)
apply(simp add: approximating_bigstep_fun_seq_wf[OF wf_nr])
apply(subst approximating_bigstep_fun_seq_wf[OF wf_r, simplified])
apply(simp add: a)
apply(simp add: IH)
done
qed
qed
corollary normalize_rules_match_list_semantics:
"(∀m a. match_list γ (f m) a p = matches γ m a p) ⟹ simple_ruleset rs ⟹
approximating_bigstep_fun γ p (normalize_rules f rs) s = approximating_bigstep_fun γ p rs s"
by(rule normalize_rules_match_list_semantics_3[where P="λ_. True"]) simp_all
lemma in_normalized_matches: "ls ∈ set (normalize_match m) ∧ matches γ ls a p ⟹ matches γ m a p"
by (meson match_list_matches matches_to_match_list_normalize)
text‹applying a function (with a prerequisite ‹Q›) to all rules›
lemma normalize_rules_property:
assumes "∀ r ∈ set rs. P (get_match r)"
and "∀m. P m ⟶ (∀m' ∈ set (f m). Q m')"
shows "∀r ∈ set (normalize_rules f rs). Q (get_match r)"
proof
fix r' assume a: "r' ∈ set (normalize_rules f rs)"
from a assms show "Q (get_match r')"
proof(induction rs)
case Nil thus ?case by simp
next
case (Cons r rs)
{
assume "r' ∈ set (normalize_rules f rs)"
from Cons.IH this have "Q (get_match r')" using Cons.prems(2) Cons.prems(3) by fastforce
} note 1=this
{
assume "r' ∈ set (normalize_rules f [r])"
hence a: "(get_match r') ∈ set (f (get_match r))" by(cases r) (auto)
with Cons.prems(2) Cons.prems(3) have "∀m'∈set (f (get_match r)). Q m'" by auto
with a have "Q (get_match r')" by blast
} note 2=this
from Cons.prems(1) have "r' ∈ set (normalize_rules f [r]) ∨ r' ∈ set (normalize_rules f rs)"
by(subst(asm) normalize_rules_fst) auto
with 1 2 show ?case
by(elim disjE)(simp)
qed
qed
text‹If a function ‹f› preserves some property of the match expressions, then this property is preserved when applying @{const normalize_rules}›
lemma normalize_rules_preserves: assumes "∀ r ∈ set rs. P (get_match r)"
and "∀m. P m ⟶ (∀m' ∈ set (f m). P m')"
shows "∀r ∈ set (normalize_rules f rs). P (get_match r)"
using normalize_rules_property[OF assms(1) assms(2)] by simp
fun normalize_rules_dnf :: "'a rule list ⇒ 'a rule list" where
"normalize_rules_dnf [] = []" |
"normalize_rules_dnf ((Rule m a)#rs) = (map (λm. Rule m a) (normalize_match m))@(normalize_rules_dnf rs)"
lemma normalize_rules_dnf_append: "normalize_rules_dnf (rs1@rs2) = normalize_rules_dnf rs1 @ normalize_rules_dnf rs2"
proof(induction rs1 rule: normalize_rules_dnf.induct)
qed(simp_all)
lemma normalize_rules_dnf_def2: "normalize_rules_dnf = normalize_rules normalize_match"
proof(simp add: fun_eq_iff, intro allI)
fix x::"'a rule list" show "normalize_rules_dnf x = normalize_rules normalize_match x"
proof(induction x)
case (Cons r rs) thus ?case by (cases r) simp
qed(simp)
qed
lemma wf_ruleset_normalize_rules_dnf: "wf_ruleset γ p rs ⟹ wf_ruleset γ p (normalize_rules_dnf rs)"
proof(induction rs)
case Nil thus ?case by simp
next
case(Cons r rs)
from Cons have IH: "wf_ruleset γ p (normalize_rules_dnf rs)" by(auto dest: wf_rulesetD)
from Cons.prems have "wf_ruleset γ p [r]" by(auto dest: wf_rulesetD)
hence "wf_ruleset γ p (normalize_rules_dnf [r])" using wf_ruleset_normalize_match by(cases r) simp
with IH wf_ruleset_append have "wf_ruleset γ p (normalize_rules_dnf [r] @ normalize_rules_dnf rs)" by fast
thus ?case using normalize_rules_dnf_def2 normalize_rules_fst by metis
qed
lemma good_ruleset_normalize_rules_dnf: "good_ruleset rs ⟹ good_ruleset (normalize_rules_dnf rs)"
using normalize_rules_dnf_def2 good_ruleset_normalize_rules by metis
lemma simple_ruleset_normalize_rules_dnf: "simple_ruleset rs ⟹ simple_ruleset (normalize_rules_dnf rs)"
using normalize_rules_dnf_def2 simple_ruleset_normalize_rules by metis
lemma "simple_ruleset rs ⟹
approximating_bigstep_fun γ p (normalize_rules_dnf rs) s = approximating_bigstep_fun γ p rs s"
unfolding normalize_rules_dnf_def2
apply(rule normalize_rules_match_list_semantics)
apply (metis matches_to_match_list_normalize)
by simp
lemma normalize_rules_dnf_correct: "wf_ruleset γ p rs ⟹
approximating_bigstep_fun γ p (normalize_rules_dnf rs) s = approximating_bigstep_fun γ p rs s"
proof(induction rs)
case Nil thus ?case by simp
next
case (Cons r rs)
show ?case
proof(induction s rule: just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
case Undecided
from Cons wf_rulesetD(2) have IH: "approximating_bigstep_fun γ p (normalize_rules_dnf rs) s = approximating_bigstep_fun γ p rs s" by fast
from Cons.prems have "wf_ruleset γ p [r]" and "wf_ruleset γ p (normalize_rules_dnf [r])"
by(auto dest: wf_rulesetD simp: wf_ruleset_normalize_rules_dnf)
with IH Undecided have
"approximating_bigstep_fun γ p (normalize_rules_dnf rs) (approximating_bigstep_fun γ p (normalize_rules_dnf [r]) Undecided) = approximating_bigstep_fun γ p (r # rs) Undecided"
apply(cases r, rename_tac m a)
apply(simp)
apply(case_tac a)
apply(simp_all add: normalize_match_correct Decision_approximating_bigstep_fun wf_ruleset_singleton)
done
hence "approximating_bigstep_fun γ p (normalize_rules_dnf [r] @ normalize_rules_dnf rs) s = approximating_bigstep_fun γ p (r # rs) s"
using Undecided ‹wf_ruleset γ p [r]› ‹wf_ruleset γ p (normalize_rules_dnf [r])›
by(simp add: approximating_bigstep_fun_seq_wf)
thus ?thesis using normalize_rules_fst normalize_rules_dnf_def2 by metis
qed
qed
fun normalized_nnf_match :: "'a match_expr ⇒ bool" where
"normalized_nnf_match MatchAny = True" |
"normalized_nnf_match (Match _ ) = True" |
"normalized_nnf_match (MatchNot (Match _)) = True" |
"normalized_nnf_match (MatchAnd m1 m2) = ((normalized_nnf_match m1) ∧ (normalized_nnf_match m2))" |
"normalized_nnf_match _ = False"
text‹Essentially, @{term normalized_nnf_match} checks for a negation normal form: Only AND is at toplevel, negation only occurs in front of literals.
Since @{typ "'a match_expr"} does not support OR, the result is in conjunction normal form.
Applying @{const normalize_match}, the reuslt is a list. Essentially, this is the disjunctive normal form.›
lemma normalize_match_already_normalized: "normalized_nnf_match m ⟹ normalize_match m = [m]"
by(induction m rule: normalize_match.induct) (simp)+
lemma normalized_nnf_match_normalize_match: "∀ m' ∈ set (normalize_match m). normalized_nnf_match m'"
proof(induction m arbitrary: rule: normalize_match.induct)
case 4 thus ?case by fastforce
qed (simp_all)
lemma normalized_nnf_match_MatchNot_D: "normalized_nnf_match (MatchNot m) ⟹ normalized_nnf_match m"
by(induction m) (simp_all)
text‹Example›
lemma "normalize_match (MatchNot (MatchAnd (Match ip_src) (Match tcp))) = [MatchNot (Match ip_src), MatchNot (Match tcp)]" by simp
subsection‹Functions which preserve @{const normalized_nnf_match}›
lemma optimize_matches_option_normalized_nnf_match: "(⋀ r. r ∈ set rs ⟹ normalized_nnf_match (get_match r)) ⟹
(⋀m m'. normalized_nnf_match m ⟹ f m = Some m' ⟹ normalized_nnf_match m') ⟹
∀ r ∈ set (optimize_matches_option f rs). normalized_nnf_match (get_match r)"
proof(induction rs)
case Nil thus ?case by simp
next
case (Cons r rs)
from Cons.IH Cons.prems have IH: "∀r∈set (optimize_matches_option f rs). normalized_nnf_match (get_match r)" by simp
from Cons.prems have "∀r∈set (optimize_matches_option f [r]). normalized_nnf_match (get_match r)"
apply(cases r)
apply(simp split: option.split)
by force
with IH show ?case by(cases r, simp split: option.split_asm)
qed
lemma optimize_matches_normalized_nnf_match: "⟦∀ r ∈ set rs. normalized_nnf_match (get_match r); ∀m. normalized_nnf_match m ⟶ normalized_nnf_match (f m) ⟧ ⟹
∀ r ∈ set (optimize_matches f rs). normalized_nnf_match (get_match r)"
unfolding optimize_matches_def
apply(rule optimize_matches_option_normalized_nnf_match)
apply(simp; fail)
apply(simp split: if_split_asm)
by blast
lemma normalize_rules_dnf_normalized_nnf_match: "∀x ∈ set (normalize_rules_dnf rs). normalized_nnf_match (get_match x)"
proof(induction rs)
case Nil thus ?case by simp
next
case (Cons r rs) thus ?case using normalized_nnf_match_normalize_match by(cases r) fastforce
qed
end
Theory Negation_Type_Matching
theory Negation_Type_Matching
imports "../Common/Negation_Type" Matching_Ternary "../Datatype_Selectors" Normalized_Matches
begin
section‹Negation Type Matching›
text‹Transform a @{typ "'a negation_type list"} to a @{typ "'a match_expr"} via conjunction.›
fun alist_and :: "'a negation_type list ⇒ 'a match_expr" where
"alist_and [] = MatchAny" |
"alist_and ((Pos e)#es) = MatchAnd (Match e) (alist_and es)" |
"alist_and ((Neg e)#es) = MatchAnd (MatchNot (Match e)) (alist_and es)"
lemma normalized_nnf_match_alist_and: "normalized_nnf_match (alist_and as)"
by(induction as rule: alist_and.induct) simp_all
lemma alist_and_append: "matches γ (alist_and (l1 @ l2)) a p ⟷ matches γ (MatchAnd (alist_and l1) (alist_and l2)) a p"
proof(induction l1)
case Nil thus ?case by (simp add: bunch_of_lemmata_about_matches)
next
case (Cons l l1) thus ?case by (cases l) (simp_all add: bunch_of_lemmata_about_matches)
qed
text‹This version of @{const alist_and} avoids the trailing @{const MatchAny}. Only intended for code.›
fun alist_and' :: "'a negation_type list ⇒ 'a match_expr" where
"alist_and' [] = MatchAny" |
"alist_and' [Pos e] = Match e" |
"alist_and' [Neg e] = MatchNot (Match e)"|
"alist_and' ((Pos e)#es) = MatchAnd (Match e) (alist_and' es)" |
"alist_and' ((Neg e)#es) = MatchAnd (MatchNot (Match e)) (alist_and' es)"
lemma alist_and': "matches (γ, α) (alist_and' as) = matches (γ, α) (alist_and as)"
by(induction as rule: alist_and'.induct) (simp_all add: bunch_of_lemmata_about_matches)
lemma normalized_nnf_match_alist_and': "normalized_nnf_match (alist_and' as)"
by(induction as rule: alist_and'.induct) simp_all
lemma matches_alist_and_alist_and':
"matches γ (alist_and' ls) a p ⟷ matches γ (alist_and ls) a p"
apply(induction ls rule: alist_and'.induct)
by(simp add: bunch_of_lemmata_about_matches)+
lemma alist_and'_append: "matches γ (alist_and' (l1 @ l2)) a p ⟷ matches γ (MatchAnd (alist_and' l1) (alist_and' l2)) a p"
proof(induction l1)
case Nil thus ?case by (simp add: bunch_of_lemmata_about_matches)
next
case (Cons l l1) thus ?case
apply (cases l)
by(simp_all add: matches_alist_and_alist_and' bunch_of_lemmata_about_matches)
qed
lemma alist_and_NegPos_map_getNeg_getPos_matches:
"(∀m∈set (getNeg spts). matches γ (MatchNot (Match (C m))) a p) ∧
(∀m∈set (getPos spts). matches γ (Match (C m)) a p)
⟷
matches γ (alist_and (NegPos_map C spts)) a p"
proof(induction spts rule: alist_and.induct)
qed(auto simp add: bunch_of_lemmata_about_matches)
fun negation_type_to_match_expr_f :: "('a ⇒ 'b) ⇒ 'a negation_type ⇒ 'b match_expr" where
"negation_type_to_match_expr_f f (Pos a) = Match (f a)" |
"negation_type_to_match_expr_f f (Neg a) = MatchNot (Match (f a))"
lemma alist_and_negation_type_to_match_expr_f_matches:
"matches γ (alist_and (NegPos_map C spts)) a p ⟷
(∀m∈set spts. matches γ (negation_type_to_match_expr_f C m) a p)"
proof(induction spts rule: alist_and.induct)
qed(auto simp add: bunch_of_lemmata_about_matches)
definition negation_type_to_match_expr :: "'a negation_type ⇒ 'a match_expr" where
"negation_type_to_match_expr m ≡ negation_type_to_match_expr_f id m"
lemma negation_type_to_match_expr_simps:
"negation_type_to_match_expr (Pos e) = (Match e)"
"negation_type_to_match_expr (Neg e) = (MatchNot (Match e))"
by(simp_all add: negation_type_to_match_expr_def)
lemma alist_and_negation_type_to_match_expr: "alist_and (n#es) = MatchAnd (negation_type_to_match_expr n) (alist_and es)"
by(cases n, simp_all add: negation_type_to_match_expr_simps)
fun to_negation_type_nnf :: "'a match_expr ⇒ 'a negation_type list" where
"to_negation_type_nnf MatchAny = []" |
"to_negation_type_nnf (Match a) = [Pos a]" |
"to_negation_type_nnf (MatchNot (Match a)) = [Neg a]" |
"to_negation_type_nnf (MatchAnd a b) = (to_negation_type_nnf a) @ (to_negation_type_nnf b)" |
"to_negation_type_nnf _ = undefined"
lemma "normalized_nnf_match m ⟹ matches γ (alist_and (to_negation_type_nnf m)) a p = matches γ m a p"
proof(induction m rule: to_negation_type_nnf.induct)
qed(simp_all add: bunch_of_lemmata_about_matches alist_and_append)
text‹Isolating the matching semantics›
fun nt_match_list :: "('a, 'packet) match_tac ⇒ action ⇒ 'packet ⇒ 'a negation_type list ⇒ bool" where
"nt_match_list _ _ _ [] = True" |
"nt_match_list γ a p ((Pos x)#xs) ⟷ matches γ (Match x) a p ∧ nt_match_list γ a p xs" |
"nt_match_list γ a p ((Neg x)#xs) ⟷ matches γ (MatchNot (Match x)) a p ∧ nt_match_list γ a p xs"
lemma nt_match_list_matches: "nt_match_list γ a p l ⟷ matches γ (alist_and l) a p"
apply(induction l rule: alist_and.induct)
apply(case_tac [!] γ)
apply(simp_all add: bunch_of_lemmata_about_matches)
done
lemma nt_match_list_simp: "nt_match_list γ a p ms ⟷
(∀m ∈ set (getPos ms). matches γ (Match m) a p) ∧ (∀m ∈ set (getNeg ms). matches γ (MatchNot (Match m)) a p)"
proof(induction γ a p ms rule: nt_match_list.induct)
case 3 thus ?case by fastforce
qed(simp_all)
lemma matches_alist_and: "matches γ (alist_and l) a p ⟷ (∀m ∈ set (getPos l). matches γ (Match m) a p) ∧ (∀m ∈ set (getNeg l). matches γ (MatchNot (Match m)) a p)"
using nt_match_list_matches nt_match_list_simp by fast
end
Theory Primitive_Normalization
theory Primitive_Normalization
imports Negation_Type_Matching
begin
section‹Primitive Normalization›
subsection‹Normalized Primitives›
text‹
Test if a ‹disc› is in the match expression.
For example, it call tell whether there are some matches for ‹Src ip›.
›
fun has_disc :: "('a ⇒ bool) ⇒ 'a match_expr ⇒ bool" where
"has_disc _ MatchAny = False" |
"has_disc disc (Match a) = disc a" |
"has_disc disc (MatchNot m) = has_disc disc m" |
"has_disc disc (MatchAnd m1 m2) = (has_disc disc m1 ∨ has_disc disc m2)"
fun has_disc_negated :: "('a ⇒ bool) ⇒ bool ⇒ 'a match_expr ⇒ bool" where
"has_disc_negated _ _ MatchAny = False" |
"has_disc_negated disc neg (Match a) = (if disc a then neg else False)" |
"has_disc_negated disc neg (MatchNot m) = has_disc_negated disc (¬ neg) m" |
"has_disc_negated disc neg (MatchAnd m1 m2) = (has_disc_negated disc neg m1 ∨ has_disc_negated disc neg m2)"
lemma "¬ has_disc_negated (λx::nat. x = 0) False (MatchAnd (Match 0) (MatchNot (Match 1)))" by eval
lemma "has_disc_negated (λx::nat. x = 0) False (MatchAnd (Match 0) (MatchNot (Match 0)))" by eval
lemma "has_disc_negated (λx::nat. x = 0) True (MatchAnd (Match 0) (MatchNot (Match 1)))" by eval
lemma "¬ has_disc_negated (λx::nat. x = 0) True (MatchAnd (Match 1) (MatchNot (Match 0)))" by eval
lemma "has_disc_negated (λx::nat. x = 0) True (MatchAnd (Match 0) (MatchNot (Match 0)))" by eval
lemma has_disc_negated_MatchNot:
"has_disc_negated disc True (MatchNot m) ⟷ has_disc_negated disc False m"
"has_disc_negated disc True m ⟷ has_disc_negated disc False (MatchNot m)"
by(induction m) (simp_all)
lemma has_disc_negated_has_disc: "has_disc_negated disc neg m ⟹ has_disc disc m"
apply(induction m arbitrary: neg)
apply(simp_all split: if_split_asm)
by blast
lemma has_disc_negated_positiv_has_disc: "has_disc_negated disc neg m ∨ has_disc_negated disc (¬ neg) m ⟷ has_disc disc m"
by(induction disc neg m arbitrary: neg rule:has_disc_negated.induct) auto
lemma has_disc_negated_disj_split:
"has_disc_negated (λa. P a ∨ Q a) neg m ⟷ has_disc_negated P neg m ∨ has_disc_negated Q neg m"
apply(induction "(λa. P a ∨ Q a)" neg m rule: has_disc_negated.induct)
apply(simp_all)
by blast
lemma has_disc_alist_and: "has_disc disc (alist_and as) ⟷ (∃ a ∈ set as. has_disc disc (negation_type_to_match_expr a))"
proof(induction as rule: alist_and.induct)
qed(simp_all add: negation_type_to_match_expr_simps)
lemma has_disc_negated_alist_and: "has_disc_negated disc neg (alist_and as) ⟷ (∃ a ∈ set as. has_disc_negated disc neg (negation_type_to_match_expr a))"
proof(induction as rule: alist_and.induct)
qed(simp_all add: negation_type_to_match_expr_simps)
lemma has_disc_alist_and': "has_disc disc (alist_and' as) ⟷ (∃ a ∈ set as. has_disc disc (negation_type_to_match_expr a))"
proof(induction as rule: alist_and'.induct)
qed(simp_all add: negation_type_to_match_expr_simps)
lemma has_disc_negated_alist_and': "has_disc_negated disc neg (alist_and' as) ⟷ (∃ a ∈ set as. has_disc_negated disc neg (negation_type_to_match_expr a))"
proof(induction as rule: alist_and'.induct)
qed(simp_all add: negation_type_to_match_expr_simps)
lemma has_disc_alist_and'_append:
"has_disc disc' (alist_and' (ls1 @ ls2)) ⟷
has_disc disc' (alist_and' ls1) ∨ has_disc disc' (alist_and' ls2)"
apply(induction ls1 arbitrary: ls2 rule: alist_and'.induct)
apply(simp_all)
apply(case_tac [!] ls2)
apply(simp_all)
done
lemma has_disc_negated_alist_and'_append:
"has_disc_negated disc' neg (alist_and' (ls1 @ ls2)) ⟷
has_disc_negated disc' neg (alist_and' ls1) ∨ has_disc_negated disc' neg (alist_and' ls2)"
apply(induction ls1 arbitrary: ls2 rule: alist_and'.induct)
apply(simp_all)
apply(case_tac [!] ls2)
apply(simp_all)
done
lemma match_list_to_match_expr_not_has_disc:
"∀a. ¬ disc (X a) ⟹ ¬ has_disc disc (match_list_to_match_expr (map (Match ∘ X) ls))"
apply(induction ls)
apply(simp; fail)
by(simp add: MatchOr_def)
lemma "matches ((λx _. bool_to_ternary (disc x)), (λ_ _. False)) (Match x) a p ⟷ has_disc disc (Match x)"
by(simp add: match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split )
fun normalized_n_primitive :: "(('a ⇒ bool) × ('a ⇒ 'b)) ⇒ ('b ⇒ bool) ⇒ 'a match_expr ⇒ bool" where
"normalized_n_primitive _ _ MatchAny = True" |
"normalized_n_primitive (disc, sel) n (Match P) = (if disc P then n (sel P) else True)" |
"normalized_n_primitive (disc, sel) n (MatchNot (Match P)) = (if disc P then False else True)" |
"normalized_n_primitive (disc, sel) n (MatchAnd m1 m2) = (normalized_n_primitive (disc, sel) n m1 ∧ normalized_n_primitive (disc, sel) n m2)" |
"normalized_n_primitive _ _ (MatchNot (MatchAnd _ _)) = False" |
"normalized_n_primitive _ _ (MatchNot (MatchNot _)) = False" |
"normalized_n_primitive _ _ (MatchNot MatchAny) = True"
lemma normalized_nnf_match_opt_MatchAny_match_expr:
"normalized_nnf_match m ⟹ normalized_nnf_match (opt_MatchAny_match_expr m)"
proof-
have "normalized_nnf_match m ⟹ normalized_nnf_match (opt_MatchAny_match_expr_once m)"
for m :: "'a match_expr"
by(induction m rule: opt_MatchAny_match_expr_once.induct) (simp_all)
thus "normalized_nnf_match m ⟹ normalized_nnf_match (opt_MatchAny_match_expr m)"
apply(simp add: opt_MatchAny_match_expr_def)
apply(induction rule: repeat_stabilize_induct)
by(simp)+
qed
lemma normalized_n_primitive_opt_MatchAny_match_expr:
"normalized_n_primitive disc_sel f m ⟹ normalized_n_primitive disc_sel f (opt_MatchAny_match_expr m)"
proof-
have "normalized_n_primitive disc_sel f m ⟹ normalized_n_primitive disc_sel f (opt_MatchAny_match_expr_once m)"
for m
proof-
{ fix disc::"('a ⇒ bool)" and sel::"('a ⇒ 'b)" and n m1 m2
have "normalized_n_primitive (disc, sel) n (opt_MatchAny_match_expr_once m1) ⟹
normalized_n_primitive (disc, sel) n (opt_MatchAny_match_expr_once m2) ⟹
normalized_n_primitive (disc, sel) n m1 ∧ normalized_n_primitive (disc, sel) n m2 ⟹
normalized_n_primitive (disc, sel) n (opt_MatchAny_match_expr_once (MatchAnd m1 m2))"
by(induction "(MatchAnd m1 m2)" rule: opt_MatchAny_match_expr_once.induct) (auto)
}note x=this
assume "normalized_n_primitive disc_sel f m"
thus ?thesis
apply(induction disc_sel f m rule: normalized_n_primitive.induct)
apply simp_all
using x by simp
qed
from this show
"normalized_n_primitive disc_sel f m ⟹ normalized_n_primitive disc_sel f (opt_MatchAny_match_expr m)"
apply(simp add: opt_MatchAny_match_expr_def)
apply(induction rule: repeat_stabilize_induct)
by(simp)+
qed
lemma normalized_n_primitive_imp_not_disc_negated:
"wf_disc_sel (disc,sel) C ⟹ normalized_n_primitive (disc,sel) f m ⟹ ¬ has_disc_negated disc False m"
apply(induction "(disc,sel)" f m rule: normalized_n_primitive.induct)
by(simp add: wf_disc_sel.simps split: if_split_asm)+
lemma normalized_n_primitive_alist_and: "normalized_n_primitive disc_sel P (alist_and as) ⟷
(∀ a ∈ set as. normalized_n_primitive disc_sel P (negation_type_to_match_expr a))"
proof(induction as)
case Nil thus ?case by simp
next
case (Cons a as) thus ?case
apply(cases disc_sel, cases a)
by(simp_all add: negation_type_to_match_expr_simps)
qed
lemma normalized_n_primitive_alist_and': "normalized_n_primitive disc_sel P (alist_and' as) ⟷
(∀ a ∈ set as. normalized_n_primitive disc_sel P (negation_type_to_match_expr a))"
apply(cases disc_sel)
apply(induction as rule: alist_and'.induct)
by(simp_all add: negation_type_to_match_expr_simps)
lemma not_has_disc_NegPos_map: "∀a. ¬ disc (C a) ⟹ ∀a∈set (NegPos_map C ls).
¬ has_disc disc (negation_type_to_match_expr a)"
by(induction C ls rule: NegPos_map.induct) (simp add: negation_type_to_match_expr_def)+
lemma not_has_disc_negated_NegPos_map: "∀a. ¬ disc (C a) ⟹ ∀a∈set (NegPos_map C ls).
¬ has_disc_negated disc False (negation_type_to_match_expr a)"
by(induction C ls rule: NegPos_map.induct) (simp add: negation_type_to_match_expr_def)+
lemma normalized_n_primitive_impossible_map: "∀a. ¬ disc (C a) ⟹
∀m∈set (map (Match ∘ (C ∘ x)) ls).
normalized_n_primitive (disc, sel) f m"
apply(intro ballI)
apply(induction ls)
apply(simp; fail)
apply(simp)
apply(case_tac m, simp_all)
apply(fastforce)
by force
lemma normalized_n_primitive_alist_and'_append:
"normalized_n_primitive (disc, sel) f (alist_and' (ls1 @ ls2)) ⟷
normalized_n_primitive (disc, sel) f (alist_and' ls1) ∧ normalized_n_primitive (disc, sel) f (alist_and' ls2)"
apply(induction ls1 arbitrary: ls2 rule: alist_and'.induct)
apply(simp_all)
apply(case_tac [!] ls2)
apply(simp_all)
done
lemma normalized_n_primitive_if_no_primitive: "normalized_nnf_match m ⟹ ¬ has_disc disc m ⟹
normalized_n_primitive (disc, sel) f m"
by(induction "(disc, sel)" f m rule: normalized_n_primitive.induct) (simp)+
lemma normalized_n_primitive_false_eq_notdisc: "normalized_nnf_match m ⟹
normalized_n_primitive (disc, sel) (λ_. False) m ⟷ ¬ has_disc disc m"
proof -
have "normalized_nnf_match m ⟹ false = (λ_. False) ⟹
¬ has_disc disc m ⟷ normalized_n_primitive (disc, sel) false m" for false
by(induction "(disc, sel)" false m rule: normalized_n_primitive.induct)
(simp)+
thus "normalized_nnf_match m ⟹ ?thesis" by simp
qed
lemma normalized_n_primitive_MatchAnd_combine_map: "normalized_n_primitive disc_sel f rst ⟹
∀m' ∈ (λspt. Match (C spt)) ` set pts. normalized_n_primitive disc_sel f m' ⟹
m' ∈ (λspt. MatchAnd (Match (C spt)) rst) ` set pts ⟹ normalized_n_primitive disc_sel f m'"
by(induction disc_sel f m' rule: normalized_n_primitive.induct)
fastforce+
subsection‹Primitive Extractor›
text‹
The following function takes a tuple of functions (@{typ "(('a ⇒ bool) × ('a ⇒ 'b))"}) and a @{typ "'a match_expr"}.
The passed function tuple must be the discriminator and selector of the datatype package.
‹primitive_extractor› filters the @{typ "'a match_expr"} and returns a tuple.
The first element of the returned tuple is the filtered primitive matches, the second element is the remaining match expression.
It requires a @{const normalized_nnf_match}.
›
fun primitive_extractor :: "(('a ⇒ bool) × ('a ⇒ 'b)) ⇒ 'a match_expr ⇒ ('b negation_type list × 'a match_expr)" where
"primitive_extractor _ MatchAny = ([], MatchAny)" |
"primitive_extractor (disc,sel) (Match a) = (if disc a then ([Pos (sel a)], MatchAny) else ([], Match a))" |
"primitive_extractor (disc,sel) (MatchNot (Match a)) = (if disc a then ([Neg (sel a)], MatchAny) else ([], MatchNot (Match a)))" |
"primitive_extractor C (MatchAnd ms1 ms2) = (
let (a1', ms1') = primitive_extractor C ms1;
(a2', ms2') = primitive_extractor C ms2
in (a1'@a2', MatchAnd ms1' ms2'))" |
"primitive_extractor _ _ = undefined"
text‹
The first part returned by @{const primitive_extractor}, here ‹as›:
A list of primitive match expressions.
For example, let ‹m = MatchAnd (Src ip1) (Dst ip2)› then, using the src ‹(disc, sel)›, the result is ‹[ip1]›.
Note that ‹Src› is stripped from the result.
The second part, here ‹ms› is the match expression which was not extracted.
Together, the first and second part match iff ‹m› matches.
›
primitive_extractor_fst_simp2:
fixes m'::"'a match_expr ⇒ 'a match_expr ⇒ 'a match_expr"
shows "fst (case primitive_extractor (disc, sel) m1 of (a1', ms1') ⇒ case primitive_extractor (disc, sel) m2 of (a2', ms2') ⇒ (a1' @ a2', m' ms1' ms2')) =
fst (primitive_extractor (disc, sel) m1) @ fst (primitive_extractor (disc, sel) m2)"
apply(cases "primitive_extractor (disc, sel) m1", simp)
apply(cases "primitive_extractor (disc, sel) m2", simp)
done
theorem primitive_extractor_correct: assumes
"normalized_nnf_match m" and "wf_disc_sel (disc, sel) C" and "primitive_extractor (disc, sel) m = (as, ms)"
shows "matches γ (alist_and (NegPos_map C as)) a p ∧ matches γ ms a p ⟷ matches γ m a p"
and "normalized_nnf_match ms"
and "¬ has_disc disc ms"
and "∀disc2. ¬ has_disc disc2 m ⟶ ¬ has_disc disc2 ms"
and "∀disc2 sel2. normalized_n_primitive (disc2, sel2) P m ⟶ normalized_n_primitive (disc2, sel2) P ms"
and "∀disc2. ¬ has_disc_negated disc2 neg m ⟶ ¬ has_disc_negated disc2 neg ms"
and "¬ has_disc disc m ⟷ as = [] ∧ ms = m"
and "¬ has_disc_negated disc False m ⟷ getNeg as = []"
and "has_disc disc m ⟹ as ≠ []"
proof -
from assms have assm3': "(as, ms) = primitive_extractor (disc, sel) m" by simp
with assms(1) assms(2) show "matches γ (alist_and (NegPos_map C as)) a p ∧ matches γ ms a p ⟷ matches γ m a p"
proof(induction "(disc, sel)" m arbitrary: as ms rule: primitive_extractor.induct)
case 4 thus ?case
apply(simp split: if_split_asm prod.split_asm add: NegPos_map_append)
apply(auto simp add: alist_and_append bunch_of_lemmata_about_matches)
done
qed(simp_all add: bunch_of_lemmata_about_matches wf_disc_sel.simps split: if_split_asm)
from assms(1) assm3' show "normalized_nnf_match ms"
proof(induction "(disc, sel)" m arbitrary: as ms rule: primitive_extractor.induct)
case 2 thus ?case by(simp split: if_split_asm)
next
case 3 thus ?case by(simp split: if_split_asm)
next
case 4 thus ?case
apply(clarify)
apply(simp split: prod.split_asm)
done
qed(simp_all)
from assms(1) assm3' show "¬ has_disc disc ms"
proof(induction "(disc, sel)" m arbitrary: as ms rule: primitive_extractor.induct)
qed(simp_all split: if_split_asm prod.split_asm)
from assms(1) assm3' show "∀disc2. ¬ has_disc disc2 m ⟶ ¬ has_disc disc2 ms"
proof(induction "(disc, sel)" m arbitrary: as ms rule: primitive_extractor.induct)
case 2 thus ?case by(simp split: if_split_asm)
next
case 3 thus ?case by(simp split: if_split_asm)
next
case 4 thus ?case by(simp split: prod.split_asm)
qed(simp_all)
from assms(1) assm3' show "∀disc2. ¬ has_disc_negated disc2 neg m ⟶ ¬ has_disc_negated disc2 neg ms"
proof(induction "(disc, sel)" m arbitrary: as ms rule: primitive_extractor.induct)
case 2 thus ?case by(simp split: if_split_asm)
next
case 3 thus ?case by(simp split: if_split_asm)
next
case 4 thus ?case by(simp split: prod.split_asm)
qed(simp_all)
from assms(1) assm3' show "∀disc2 sel2. normalized_n_primitive (disc2, sel2) P m ⟶ normalized_n_primitive (disc2, sel2) P ms"
apply(induction "(disc, sel)" m arbitrary: as ms rule: primitive_extractor.induct)
apply(simp)
apply(simp split: if_split_asm)
apply(simp split: if_split_asm)
apply(simp split: prod.split_asm)
apply(simp_all)
done
from assms(1) assm3' show "¬ has_disc disc m ⟷ as = [] ∧ ms = m"
proof(induction "(disc, sel)" m arbitrary: as ms rule: primitive_extractor.induct)
case 2 thus ?case by(simp split: if_split_asm)
next
case 3 thus ?case by(simp split: if_split_asm)
next
case 4 thus ?case by(auto split: prod.split_asm)
qed(simp_all)
from assms(1) assm3' show "¬ has_disc_negated disc False m ⟷ getNeg as = []"
proof(induction "(disc, sel)" m arbitrary: as ms rule: primitive_extractor.induct)
case 2 thus ?case by(simp split: if_split_asm)
next
case 3 thus ?case by(simp split: if_split_asm)
next
case 4 thus ?case by(simp add: getNeg_append split: prod.split_asm)
qed(simp_all)
from assms(1) assm3' show "has_disc disc m ⟹ as ≠ []"
proof(induction "(disc, sel)" m arbitrary: as ms rule: primitive_extractor.induct)
case 4 thus ?case apply(simp split: prod.split_asm)
by metis
qed(simp_all)
qed
has_disc_negated_primitive_extractor:
assumes "normalized_nnf_match m"
shows "has_disc_negated disc False m ⟷ (∃a. Neg a ∈ set (fst (primitive_extractor (disc, sel) m)))"
proof -
obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
hence "has_disc_negated disc False m ⟷ (∃a. Neg a ∈ set as)"
using assms proof(induction m arbitrary: as ms)
case Match thus ?case
by(simp split: if_split_asm) fastforce
next
case (MatchNot m)
thus ?case
proof(induction m)
case Match thus ?case by (simp, fastforce)
qed(simp_all)
next
case (MatchAnd m1 m2) thus ?case
apply(cases "primitive_extractor (disc, sel) m1")
apply(cases "primitive_extractor (disc, sel) m2")
by auto
qed(simp_all split: if_split_asm)
thus ?thesis using asms by simp
qed
primitive_extractor_reassemble_preserves:
"wf_disc_sel (disc, sel) C ⟹
normalized_nnf_match m ⟹
P m ⟹
P MatchAny ⟹
primitive_extractor (disc, sel) m = (as, ms) ⟹
(⋀m1 m2. P (MatchAnd m1 m2) ⟷ P m1 ∧ P m2) ⟹
(⋀ls1 ls2. P (alist_and' (ls1 @ ls2)) ⟷ P (alist_and' ls1) ∧ P (alist_and' ls2)) ⟹
P (alist_and' (NegPos_map C as))"
proof(induction "(disc, sel)" m arbitrary: as ms rule: primitive_extractor.induct)
case 2 thus ?case
apply(simp split: if_split_asm)
apply(clarify)
by(simp add: wf_disc_sel.simps)
next
case 3 thus ?case
apply(simp split: if_split_asm)
apply(clarify)
by(simp add: wf_disc_sel.simps)
next
case (4 m1 m2 as ms)
from 4 show ?case
apply(simp)
apply(simp split: prod.split_asm)
apply(clarify)
apply(simp add: NegPos_map_append)
done
qed(simp_all split: if_split_asm)
primitive_extractor_reassemble_not_has_disc:
"wf_disc_sel (disc, sel) C ⟹
normalized_nnf_match m ⟹ ¬ has_disc disc' m ⟹
primitive_extractor (disc, sel) m = (as, ms) ⟹
¬ has_disc disc' (alist_and' (NegPos_map C as))"
apply(rule primitive_extractor_reassemble_preserves)
by(simp_all add: NegPos_map_append has_disc_alist_and'_append)
primitive_extractor_reassemble_not_has_disc_negated:
"wf_disc_sel (disc, sel) C ⟹
normalized_nnf_match m ⟹ ¬ has_disc_negated disc' neg m ⟹
primitive_extractor (disc, sel) m = (as, ms) ⟹
¬ has_disc_negated disc' neg (alist_and' (NegPos_map C as))"
apply(rule primitive_extractor_reassemble_preserves)
by(simp_all add: NegPos_map_append has_disc_negated_alist_and'_append)
primitive_extractor_reassemble_normalized_n_primitive:
"wf_disc_sel (disc, sel) C ⟹
normalized_nnf_match m ⟹ normalized_n_primitive (disc1, sel1) f m ⟹
primitive_extractor (disc, sel) m = (as, ms) ⟹
normalized_n_primitive (disc1, sel1) f (alist_and' (NegPos_map C as))"
apply(rule primitive_extractor_reassemble_preserves)
by(simp_all add: NegPos_map_append normalized_n_primitive_alist_and'_append)
primitive_extractor_matchesE: "wf_disc_sel (disc,sel) C ⟹ normalized_nnf_match m ⟹ primitive_extractor (disc, sel) m = (as, ms)
⟹
(normalized_nnf_match ms ⟹ ¬ has_disc disc ms ⟹ (∀disc2. ¬ has_disc disc2 m ⟶ ¬ has_disc disc2 ms) ⟹ matches_other ⟷ matches γ ms a p)
⟹
matches γ (alist_and (NegPos_map C as)) a p ∧ matches_other ⟷ matches γ m a p"
using primitive_extractor_correct(1,2,3,4) by metis
primitive_extractor_matches_lastE: "wf_disc_sel (disc,sel) C ⟹ normalized_nnf_match m ⟹ primitive_extractor (disc, sel) m = (as, ms)
⟹
(normalized_nnf_match ms ⟹ ¬ has_disc disc ms ⟹ (∀disc2. ¬ has_disc disc2 m ⟶ ¬ has_disc disc2 ms) ⟹ matches γ ms a p)
⟹
matches γ (alist_and (NegPos_map C as)) a p ⟷ matches γ m a p"
using primitive_extractor_correct(1,2,3,4) by metis
text‹The lemmas @{thm primitive_extractor_matchesE} and @{thm primitive_extractor_matches_lastE} can be used as
erule to solve goals about consecutive application of @{const primitive_extractor}.
They should be used as ‹primitive_extractor_matchesE[OF wf_disc_sel_for_first_extracted_thing]›.
›
subsection‹Normalizing and Optimizing Primitives›
text‹
Normalize primitives by a function ‹f› with type @{typ "'b negation_type list ⇒ 'b list"}.
@{typ "'b"} is a primitive type, e.g. ipt-ipv4range.
‹f› takes a conjunction list of negated primitives and must compress them such that:
\begin{enumerate}
\item no negation occurs in the output
\item the output is a disjunction of the primitives, i.e. multiple primitives in one rule are compressed to at most one primitive (leading to multiple rules)
\end{enumerate}
Example with IP addresses:
\begin{verbatim}
f [10.8.0.0/16, 10.0.0.0/8] = [10.0.0.0/8] f compresses to one range
f [10.0.0.0, 192.168.0.01] = [] range is empty, rule can be dropped
f [Neg 41] = [{0..40}, {42..ipv4max}] one rule is translated into multiple rules to translate negation
f [Neg 41, {20..50}, {30..50}] = [{30..40}, {42..50}] input: conjunction list, output disjunction list!
\end{verbatim}
›
definition normalize_primitive_extract :: "(('a ⇒ bool) × ('a ⇒ 'b)) ⇒
('b ⇒ 'a) ⇒
('b negation_type list ⇒ 'b list) ⇒
'a match_expr ⇒
'a match_expr list" where
"normalize_primitive_extract (disc_sel) C f m ≡ (case primitive_extractor (disc_sel) m
of (spts, rst) ⇒ map (λspt. (MatchAnd (Match (C spt))) rst) (f spts))"
text‹
If ‹f› has the properties described above, then @{const normalize_primitive_extract} is a valid transformation of a match expression›
normalize_primitive_extract: assumes "normalized_nnf_match m" and "wf_disc_sel disc_sel C" and
"∀ml. (match_list γ (map (Match ∘ C) (f ml)) a p ⟷ matches γ (alist_and (NegPos_map C ml)) a p)"
shows "match_list γ (normalize_primitive_extract disc_sel C f m) a p ⟷ matches γ m a p"
proof -
obtain as ms where pe: "primitive_extractor disc_sel m = (as, ms)" by fastforce
from pe primitive_extractor_correct(1)[OF assms(1), where γ=γ and a=a and p=p] assms(2) have
"matches γ m a p ⟷ matches γ (alist_and (NegPos_map C as)) a p ∧ matches γ ms a p" by(cases disc_sel, blast)
also have "… ⟷ match_list γ (map (Match ∘ C) (f as)) a p ∧ matches γ ms a p" using assms(3) by simp
also have "… ⟷ match_list γ (map (λspt. MatchAnd (Match (C spt)) ms) (f as)) a p"
by(simp add: match_list_matches bunch_of_lemmata_about_matches)
also have "... ⟷ match_list γ (normalize_primitive_extract disc_sel C f m) a p"
by(simp add: normalize_primitive_extract_def pe)
finally show ?thesis by simp
qed
thm match_list_semantics[of γ "(map (Match ∘ C) (f ml))" a p "[(alist_and (NegPos_map C ml))]"]
corollary normalize_primitive_extract_semantics: assumes "normalized_nnf_match m" and "wf_disc_sel disc_sel C" and
"∀ml. (match_list γ (map (Match ∘ C) (f ml)) a p ⟷ matches γ (alist_and (NegPos_map C ml)) a p)"
shows "approximating_bigstep_fun γ p (map (λm. Rule m a) (normalize_primitive_extract disc_sel C f m)) s =
approximating_bigstep_fun γ p [Rule m a] s"
proof -
from normalize_primitive_extract[OF assms(1) assms(2) assms(3)] have
"match_list γ (normalize_primitive_extract disc_sel C f m) a p = matches γ m a p" .
also have "… ⟷ match_list γ [m] a p" by simp
finally show ?thesis using match_list_semantics[of γ "(normalize_primitive_extract disc_sel C f m)" a p "[m]"] by simp
qed
normalize_primitive_extract_preserves_nnf_normalized:
assumes "normalized_nnf_match m"
and "wf_disc_sel (disc, sel) C"
shows "∀mn ∈ set (normalize_primitive_extract (disc, sel) C f m). normalized_nnf_match mn"
proof
fix mn
assume assm2: "mn ∈ set (normalize_primitive_extract (disc, sel) C f m)"
obtain as ms where as_ms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
from primitive_extractor_correct(2)[OF assms(1) assms(2) as_ms] have "normalized_nnf_match ms" by simp
from assm2 as_ms have normalize_primitive_extract_unfolded: "mn ∈ ((λspt. MatchAnd (Match (C spt)) ms) ` set (f as))"
unfolding normalize_primitive_extract_def by force
with ‹normalized_nnf_match ms› show "normalized_nnf_match mn" by fastforce
qed
normalize_rules_primitive_extract_preserves_nnf_normalized:
"∀r ∈ set rs. normalized_nnf_match (get_match r) ⟹ wf_disc_sel disc_sel C ⟹
∀r ∈ set (normalize_rules (normalize_primitive_extract disc_sel C f) rs). normalized_nnf_match (get_match r)"
apply(rule normalize_rules_preserves[where P="normalized_nnf_match" and f="(normalize_primitive_extract disc_sel C f)"])
apply(simp; fail)
apply(cases disc_sel)
using normalize_primitive_extract_preserves_nnf_normalized by fast
text‹If something is normalized for disc2 and disc2 ‹≠› disc1 and we do something on disc1, then disc2 remains normalized›
normalize_primitive_extract_preserves_unrelated_normalized_n_primitive:
assumes "normalized_nnf_match m"
and "normalized_n_primitive (disc2, sel2) P m"
and "wf_disc_sel (disc1, sel1) C"
and "∀a. ¬ disc2 (C a)"
shows "∀mn ∈ set (normalize_primitive_extract (disc1, sel1) C f m). normalized_n_primitive (disc2, sel2) P mn"
proof
fix mn
assume assm2: "mn ∈ set (normalize_primitive_extract (disc1, sel1) C f m)"
obtain as ms where as_ms: "primitive_extractor (disc1, sel1) m = (as, ms)" by fastforce
from as_ms primitive_extractor_correct[OF assms(1) assms(3)] have
"¬ has_disc disc1 ms"
and "normalized_n_primitive (disc2, sel2) P ms"
apply -
apply(fast)
using assms(2) by(fast)
from assm2 as_ms have normalize_primitive_extract_unfolded: "mn ∈ ((λspt. MatchAnd (Match (C spt)) ms) ` set (f as))"
unfolding normalize_primitive_extract_def by force
from normalize_primitive_extract_unfolded obtain Casms where Casms: "mn = (MatchAnd (Match (C Casms)) ms)" by blast
from ‹normalized_n_primitive (disc2, sel2) P ms› assms(4) have "normalized_n_primitive (disc2, sel2) P (MatchAnd (Match (C Casms)) ms)"
by(simp)
with Casms show "normalized_n_primitive (disc2, sel2) P mn" by blast
qed
normalize_primitive_extract_normalizes_n_primitive:
fixes disc::"('a ⇒ bool)" and sel::"('a ⇒ 'b)" and f::"('b negation_type list ⇒ 'b list)"
assumes "normalized_nnf_match m"
and "wf_disc_sel (disc, sel) C"
and np: "∀as. (∀ a' ∈ set (f as). P a')"
shows "∀m' ∈ set (normalize_primitive_extract (disc, sel) C f m). normalized_n_primitive (disc, sel) P m'"
proof
fix m' assume a: "m'∈set (normalize_primitive_extract (disc, sel) C f m)"
have nnf: "∀m' ∈ set (normalize_primitive_extract (disc, sel) C f m). normalized_nnf_match m'"
using normalize_primitive_extract_preserves_nnf_normalized assms by blast
with a have normalized_m': "normalized_nnf_match m'" by simp
from a obtain as ms where as_ms: "primitive_extractor (disc, sel) m = (as, ms)"
unfolding normalize_primitive_extract_def by fastforce
with a have prems: "m' ∈ set (map (λspt. MatchAnd (Match (C spt)) ms) (f as))"
unfolding normalize_primitive_extract_def by simp
from primitive_extractor_correct(2)[OF assms(1) assms(2) as_ms] have "normalized_nnf_match ms" .
show "normalized_n_primitive (disc, sel) P m'"
proof(cases "f as = []")
case True thus "normalized_n_primitive (disc, sel) P m'" using prems by simp
next
case False
with prems obtain spt where "m' = MatchAnd (Match (C spt)) ms" and "spt ∈ set (f as)" by auto
from primitive_extractor_correct(3)[OF assms(1) assms(2) as_ms] have "¬ has_disc disc ms" .
with ‹normalized_nnf_match ms› have "normalized_n_primitive (disc, sel) P ms"
by(induction "(disc, sel)" P ms rule: normalized_n_primitive.induct) simp_all
from ‹wf_disc_sel (disc, sel) C› have "(sel (C spt)) = spt" by(simp add: wf_disc_sel.simps)
with np ‹spt ∈ set (f as)› have "P (sel (C spt))" by simp
show "normalized_n_primitive (disc, sel) P m'"
apply(simp add: ‹m' = MatchAnd (Match (C spt)) ms›)
apply(rule conjI)
apply(simp_all add: ‹normalized_n_primitive (disc, sel) P ms›)
apply(simp add: ‹P (sel (C spt))›)
done
qed
qed
primitive_extractor_negation_type_matching1:
assumes wf: "wf_disc_sel (disc, sel) C"
and normalized: "normalized_nnf_match m"
and a1: "primitive_extractor (disc, sel) m = (as, rest)"
and a2: "matches γ m a p"
shows "(∀m∈set (map C (getPos as)). matches γ (Match m) a p) ∧
(∀m∈set (map C (getNeg as)). matches γ (MatchNot (Match m)) a p)"
proof -
from primitive_extractor_correct(1)[OF normalized wf a1] a2 have
"matches γ (alist_and (NegPos_map C as)) a p ∧ matches γ rest a p" by fast
hence "matches γ (alist_and (NegPos_map C as)) a p" by blast
with Negation_Type_Matching.matches_alist_and have
"(∀m∈set (getPos (NegPos_map C as)). matches γ (Match m) a p) ∧
(∀m∈set (getNeg (NegPos_map C as)). matches γ (MatchNot (Match m)) a p)" by metis
with getPos_NegPos_map_simp2 getNeg_NegPos_map_simp2 show ?thesis by metis
qed
text‹@{const normalized_n_primitive} does NOT imply @{const normalized_nnf_match}›
lemma "∃m. normalized_n_primitive disc_sel f m ⟶ ¬ normalized_nnf_match m"
by(rule_tac x="MatchNot MatchAny" in exI) (simp)
lemma remove_unknowns_generic_not_has_disc: "¬ has_disc C m ⟹ ¬ has_disc C (remove_unknowns_generic γ a m)"
by(induction γ a m rule: remove_unknowns_generic.induct) (simp_all add: remove_unknowns_generic_simps2)
lemma remove_unknowns_generic_not_has_disc_negated: "¬ has_disc_negated C neg m ⟹ ¬ has_disc_negated C neg (remove_unknowns_generic γ a m)"
by(induction γ a m rule: remove_unknowns_generic.induct) (simp_all add: remove_unknowns_generic_simps2)
lemma remove_unknowns_generic_normalized_n_primitive: "normalized_n_primitive disc_sel f m ⟹
normalized_n_primitive disc_sel f (remove_unknowns_generic γ a m)"
proof(induction γ a m rule: remove_unknowns_generic.induct)
case 6 thus ?case by(case_tac disc_sel, simp add: remove_unknowns_generic_simps2)
qed(simp_all add: remove_unknowns_generic_simps2)
lemma normalize_match_preserves_disc_negated:
shows "(∃m_DNF ∈ set (normalize_match m). has_disc_negated disc neg m_DNF) ⟹ has_disc_negated disc neg m"
proof(induction m rule: normalize_match.induct)
case 3 thus ?case by (simp) blast
next
case 4
from 4 show ?case by(simp) blast
qed(simp_all)
text‹@{const has_disc_negated} is a structural property and @{const normalize_match} is a semantical property.
@{const normalize_match} removes subexpressions which cannot match. Thus, we cannot show (without complicated assumptions)
the opposite direction of @{thm normalize_match_preserves_disc_negated}, because a negated primitive
might occur in a subexpression which will be optimized away.›
corollary i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day:
"¬ has_disc_negated disc neg m ⟹ ∀ m_DNF ∈ set (normalize_match m). ¬ has_disc_negated disc neg m_DNF"
using normalize_match_preserves_disc_negated by blast
lemma not_has_disc_opt_MatchAny_match_expr:
"¬ has_disc disc m ⟹ ¬ has_disc disc (opt_MatchAny_match_expr m)"
proof -
have "¬ has_disc disc m ⟹ ¬ has_disc disc (opt_MatchAny_match_expr_once m)" for m
by(induction m rule: opt_MatchAny_match_expr_once.induct) simp_all
thus "¬ has_disc disc m ⟹ ¬ has_disc disc (opt_MatchAny_match_expr m)"
apply(simp add: opt_MatchAny_match_expr_def)
apply(rule repeat_stabilize_induct)
by(simp)+
qed
lemma not_has_disc_negated_opt_MatchAny_match_expr:
"¬ has_disc_negated disc neg m ⟹ ¬ has_disc_negated disc neg (opt_MatchAny_match_expr m)"
proof -
have "¬ has_disc_negated disc neg m ⟹ ¬ has_disc_negated disc neg (opt_MatchAny_match_expr_once m)"
for m
by(induction m arbitrary: neg rule:opt_MatchAny_match_expr_once.induct) (simp_all)
thus "¬ has_disc_negated disc neg m ⟹ ¬ has_disc_negated disc neg (opt_MatchAny_match_expr m)"
apply(simp add: opt_MatchAny_match_expr_def)
apply(rule repeat_stabilize_induct)
by(simp)+
qed
lemma normalize_match_preserves_nodisc:
"¬ has_disc disc m ⟹ m' ∈ set (normalize_match m) ⟹ ¬ has_disc disc m'"
proof -
have "¬ has_disc disc m ⟶ (∀m' ∈ set (normalize_match m). ¬ has_disc disc m')"
by(induction m rule: normalize_match.induct) (safe,auto)
thus "¬ has_disc disc m ⟹ m' ∈ set (normalize_match m) ⟹ ¬ has_disc disc m'" by blast
qed
lemma not_has_disc_normalize_match:
"¬ has_disc_negated disc neg m ⟹ m' ∈ set (normalize_match m) ⟹ ¬ has_disc_negated disc neg m'"
using i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day by blast
lemma normalize_match_preserves_normalized_n_primitive:
"normalized_n_primitive disc_sel f rst ⟹
∀ m ∈ set (normalize_match rst). normalized_n_primitive disc_sel f m"
apply(cases disc_sel, simp)
apply(induction rst rule: normalize_match.induct)
apply(simp; fail)
apply(simp; fail)
apply(simp; fail)
using normalized_n_primitive.simps(5) apply metis
by simp+
subsection‹Optimizing a match expression›
text‹Optimizes a match expression with a function that takes @{typ "'b negation_type list"}
and returns @{typ "('b list × 'b list) option"}.
The function should return @{const None} if the match expression cannot match.
It returns @{term "Some (as_pos, as_neg)"} where @{term as_pos} and @{term as_neg} are lists of
primitives. Positive and Negated.
The result is one match expression.
In contrast @{const normalize_primitive_extract} returns a list of match expression, to be read es their disjunction.›
definition compress_normalize_primitive :: "(('a ⇒ bool) × ('a ⇒ 'b)) ⇒ ('b ⇒ 'a) ⇒
('b negation_type list ⇒ ('b list × 'b list) option) ⇒
'a match_expr ⇒ 'a match_expr option" where
"compress_normalize_primitive disc_sel C f m ≡ (case primitive_extractor disc_sel m of (as, rst) ⇒
(map_option (λ(as_pos, as_neg). MatchAnd
(alist_and' (NegPos_map C ((map Pos as_pos)@(map Neg as_neg))))
rst
) (f as)))"
lemma compress_normalize_primitive_nnf: "wf_disc_sel disc_sel C ⟹
normalized_nnf_match m ⟹ compress_normalize_primitive disc_sel C f m = Some m' ⟹
normalized_nnf_match m'"
apply(case_tac "primitive_extractor disc_sel m")
apply(simp add: compress_normalize_primitive_def)
apply(clarify)
apply (simp add: normalized_nnf_match_alist_and')
apply(cases disc_sel, simp)
using primitive_extractor_correct(2) by blast
lemma compress_normalize_primitive_not_introduces_C:
assumes notdisc: "¬ has_disc disc m"
and wf: "wf_disc_sel (disc,sel) C'"
and nm: "normalized_nnf_match m"
and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
and f_preserves: "⋀as_pos as_neg. f [] = Some (as_pos, as_neg) ⟹ as_pos = [] ∧ as_neg = []"
shows "¬ has_disc disc m'"
proof -
obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
from notdisc primitive_extractor_correct(4)[OF nm wf asms] have 1: "¬ has_disc disc ms" by simp
from notdisc primitive_extractor_correct(7)[OF nm wf asms] have 2: "as = [] ∧ ms = m" by simp
from 1 2 some show ?thesis by(auto dest: f_preserves simp add: compress_normalize_primitive_def asms)
qed
lemma compress_normalize_primitive_not_introduces_C_negated:
assumes notdisc: "¬ has_disc_negated disc False m"
and wf: "wf_disc_sel (disc,sel) C"
and nm: "normalized_nnf_match m"
and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
and f_preserves: "⋀as as_pos as_neg. f as = Some (as_pos, as_neg) ⟹ getNeg as = [] ⟹ as_neg = []"
shows "¬ has_disc_negated disc False m'"
proof -
obtain as ms where asms: "primitive_extractor (disc,sel) m = (as, ms)" by fastforce
from notdisc primitive_extractor_correct(6)[OF nm wf asms] have 1: "¬ has_disc_negated disc False ms" by simp
from asms notdisc has_disc_negated_primitive_extractor[OF nm, where disc=disc and sel=sel] have
"∀a. Neg a ∉ set as" by(simp)
hence "getNeg as = []" by (meson NegPos_set(5) image_subset_iff last_in_set)
with f_preserves have f_preserves': "⋀as_pos as_neg. f as = Some (as_pos, as_neg) ⟹ as_neg = []" by simp
from 1 have "⋀ a b.¬ has_disc_negated disc False (MatchAnd (alist_and' (NegPos_map C (map Pos a))) ms)"
by(simp add: has_disc_negated_alist_and' NegPos_map_map_Pos negation_type_to_match_expr_simps)
with some show ?thesis by(auto dest: f_preserves' simp add: compress_normalize_primitive_def asms)
qed
lemma compress_normalize_primitive_Some:
assumes normalized: "normalized_nnf_match m"
and wf: "wf_disc_sel (disc,sel) C"
and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
and f_correct: "⋀as as_pos as_neg. f as = Some (as_pos, as_neg) ⟹
matches γ (alist_and (NegPos_map C ((map Pos as_pos)@(map Neg as_neg)))) a p ⟷
matches γ (alist_and (NegPos_map C as)) a p"
shows "matches γ m' a p ⟷ matches γ m a p"
using some
apply(simp add: compress_normalize_primitive_def)
apply(case_tac "primitive_extractor (disc,sel) m")
apply(rename_tac as rst, simp)
apply(drule primitive_extractor_correct(1)[OF normalized wf, where γ=γ and a=a and p=p])
apply(elim exE conjE)
apply(drule f_correct)
by (meson matches_alist_and_alist_and' bunch_of_lemmata_about_matches(1))
lemma compress_normalize_primitive_None:
assumes normalized: "normalized_nnf_match m"
and wf: "wf_disc_sel (disc,sel) C"
and none: "compress_normalize_primitive (disc,sel) C f m = None"
and f_correct: "⋀as. f as = None ⟹ ¬ matches γ (alist_and (NegPos_map C as)) a p"
shows "¬ matches γ m a p"
using none
apply(simp add: compress_normalize_primitive_def)
apply(case_tac "primitive_extractor (disc, sel) m")
apply(auto dest: primitive_extractor_correct(1)[OF assms(1) wf] f_correct)
done
lemma compress_normalize_primitive_hasdisc:
assumes am: "¬ has_disc disc2 m"
and wf: "wf_disc_sel (disc,sel) C"
and disc: "(∀a. ¬ disc2 (C a))"
and nm: "normalized_nnf_match m"
and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
shows "normalized_nnf_match m' ∧ ¬ has_disc disc2 m'"
proof -
from compress_normalize_primitive_nnf[OF wf nm some] have goal1: "normalized_nnf_match m'" .
obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
from am primitive_extractor_correct(4)[OF nm wf asms] have 1: "¬ has_disc disc2 ms" by simp
{ fix is_pos is_neg
from disc have x1: "¬ has_disc disc2 (alist_and' (NegPos_map C (map Pos is_pos)))"
by(simp add: has_disc_alist_and' NegPos_map_map_Pos negation_type_to_match_expr_simps)
from disc have x2: "¬ has_disc disc2 (alist_and' (NegPos_map C (map Neg is_neg)))"
by(simp add: has_disc_alist_and' NegPos_map_map_Neg negation_type_to_match_expr_simps)
from x1 x2 have "¬ has_disc disc2 (alist_and' (NegPos_map C (map Pos is_pos @ map Neg is_neg)))"
apply(simp add: NegPos_map_append has_disc_alist_and') by blast
}
with some have "¬ has_disc disc2 m'"
apply(simp add: compress_normalize_primitive_def asms)
apply(elim exE conjE)
using 1 by fastforce
with goal1 show ?thesis by simp
qed
lemma compress_normalize_primitive_hasdisc_negated:
assumes am: "¬ has_disc_negated disc2 neg m"
and wf: "wf_disc_sel (disc,sel) C"
and disc: "(∀a. ¬ disc2 (C a))"
and nm: "normalized_nnf_match m"
and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
shows "normalized_nnf_match m' ∧ ¬ has_disc_negated disc2 neg m'"
proof -
from compress_normalize_primitive_nnf[OF wf nm some] have goal1: "normalized_nnf_match m'" .
obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
from am primitive_extractor_correct(6)[OF nm wf asms] have 1: "¬ has_disc_negated disc2 neg ms" by simp
{ fix is_pos is_neg
from disc have x1: "¬ has_disc_negated disc2 neg (alist_and' (NegPos_map C (map Pos is_pos)))"
by(simp add: has_disc_negated_alist_and' NegPos_map_map_Pos negation_type_to_match_expr_simps)
from disc have x2: "¬ has_disc_negated disc2 neg (alist_and' (NegPos_map C (map Neg is_neg)))"
by(simp add: has_disc_negated_alist_and' NegPos_map_map_Neg negation_type_to_match_expr_simps)
from x1 x2 have "¬ has_disc_negated disc2 neg (alist_and' (NegPos_map C (map Pos is_pos @ map Neg is_neg)))"
apply(simp add: NegPos_map_append has_disc_negated_alist_and') by blast
}
with some have "¬ has_disc_negated disc2 neg m'"
apply(simp add: compress_normalize_primitive_def asms)
apply(elim exE conjE)
using 1 by fastforce
with goal1 show ?thesis by simp
qed
thm normalize_primitive_extract_preserves_unrelated_normalized_n_primitive
lemma compress_normalize_primitve_preserves_normalized_n_primitive:
assumes am: "normalized_n_primitive (disc2, sel2) P m"
and wf: "wf_disc_sel (disc,sel) C"
and disc: "(∀a. ¬ disc2 (C a))"
and nm: "normalized_nnf_match m"
and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
shows "normalized_nnf_match m' ∧ normalized_n_primitive (disc2, sel2) P m'"
proof -
from compress_normalize_primitive_nnf[OF wf nm some] have goal1: "normalized_nnf_match m'" .
obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
from am primitive_extractor_correct[OF nm wf asms] have 1: "normalized_n_primitive (disc2, sel2) P ms" by fast
{ fix iss
from disc have "normalized_n_primitive (disc2, sel2) P (alist_and (NegPos_map C iss))"
apply(induction iss)
apply(simp_all)
apply(rename_tac i iss, case_tac i)
apply(simp_all)
done
}
with some have "normalized_n_primitive (disc2, sel2) P m'"
apply(simp add: compress_normalize_primitive_def asms)
apply(elim exE conjE)
using 1 normalized_n_primitive_alist_and' normalized_n_primitive_alist_and
normalized_n_primitive.simps(4) by blast
with goal1 show ?thesis by simp
qed
subsection‹Processing a list of normalization functions›
fun compress_normalize_primitive_monad :: "('a match_expr ⇒ 'a match_expr option) list ⇒ 'a match_expr ⇒ 'a match_expr option" where
"compress_normalize_primitive_monad [] m = Some m" |
"compress_normalize_primitive_monad (f#fs) m = (case f m of None ⇒ None
| Some m' ⇒ compress_normalize_primitive_monad fs m')"
lemma compress_normalize_primitive_monad:
assumes "⋀m m' f. f ∈ set fs ⟹ normalized_nnf_match m ⟹ f m = Some m' ⟹ matches γ m' a p ⟷ matches γ m a p"
and "⋀m m' f. f ∈ set fs ⟹ normalized_nnf_match m ⟹ f m = Some m' ⟹ normalized_nnf_match m'"
and "normalized_nnf_match m"
and "(compress_normalize_primitive_monad fs m) = Some m'"
shows "matches γ m' a p ⟷ matches γ m a p" (is ?goal1)
and "normalized_nnf_match m'" (is ?goal2)
proof -
have goals: "?goal1 ∧ ?goal2"
using assms proof(induction fs arbitrary: m)
case Nil thus ?case by simp
next
case (Cons f fs)
from Cons.prems(1) have IH_prem1:
"(⋀f m m'. f ∈ set fs ⟹ normalized_nnf_match m ⟹ f m = Some m' ⟹ matches γ m' a p = matches γ m a p)" by auto
from Cons.prems(2) have IH_prem2:
"(⋀f m m'. f ∈ set fs ⟹ normalized_nnf_match m ⟹ f m = Some m' ⟹ normalized_nnf_match m')" by auto
from Cons.IH IH_prem1 IH_prem2 have
IH: "⋀m. normalized_nnf_match m ⟹ compress_normalize_primitive_monad fs m = Some m' ⟹
(matches γ m' a p ⟷ matches γ m a p) ∧ ?goal2" by fast
show ?case
proof(cases "f m")
case None thus ?thesis using Cons.prems by auto
next
case(Some m'')
from Some Cons.prems(1)[of f] Cons.prems(3) have 1: "matches γ m'' a p = matches γ m a p" by simp
from Some Cons.prems(2)[of f] Cons.prems(3) have 2: "normalized_nnf_match m''" by simp
from Some have "compress_normalize_primitive_monad (f # fs) m = compress_normalize_primitive_monad fs m''" by simp
thus ?thesis using Cons.prems(4) IH 1 2 by auto
qed
qed
from goals show ?goal1 by simp
from goals show ?goal2 by simp
qed
lemma compress_normalize_primitive_monad_None:
assumes "⋀m m' f. f ∈ set fs ⟹ normalized_nnf_match m ⟹ f m = Some m' ⟹ matches γ m' a p ⟷ matches γ m a p"
and "⋀m f. f ∈ set fs ⟹ normalized_nnf_match m ⟹ f m = None ⟹ ¬ matches γ m a p"
and "⋀m m' f. f ∈ set fs ⟹ normalized_nnf_match m ⟹ f m = Some m' ⟹ normalized_nnf_match m'"
and "normalized_nnf_match m"
and "(compress_normalize_primitive_monad fs m) = None"
shows "¬ matches γ m a p"
using assms proof(induction fs arbitrary: m)
case Nil thus ?case by simp
next
case (Cons f fs)
from Cons.prems(1) have IH_prem1:
"(⋀f m m'. f ∈ set fs ⟹ normalized_nnf_match m ⟹ f m = Some m' ⟹ matches γ m' a p = matches γ m a p)" by auto
from Cons.prems(2) have IH_prem2:
"(⋀f m m'. f ∈ set fs ⟹ normalized_nnf_match m ⟹ f m = None ⟹ ¬ matches γ m a p)" by auto
from Cons.prems(3) have IH_prem3:
"(⋀f m m'. f ∈ set fs ⟹ normalized_nnf_match m ⟹ f m = Some m' ⟹ normalized_nnf_match m')" by auto
from Cons.IH IH_prem1 IH_prem2 IH_prem3 have
IH: "⋀m. normalized_nnf_match m ⟹ compress_normalize_primitive_monad fs m = None ⟹ ¬ matches γ m a p" by blast
show ?case
proof(cases "f m")
case None thus ?thesis using Cons.prems(4) Cons.prems(2) Cons.prems(3) by auto
next
case(Some m'')
from Some Cons.prems(3)[of f] Cons.prems(4) have 2: "normalized_nnf_match m''" by simp
from Some have "compress_normalize_primitive_monad (f # fs) m = compress_normalize_primitive_monad fs m''" by simp
hence "¬ matches γ m'' a p" using Cons.prems(5) IH 2 by simp
thus ?thesis using Cons.prems(1) Cons.prems(4) Some by auto
qed
qed
lemma compress_normalize_primitive_monad_preserves:
assumes "⋀m m' f. f ∈ set fs ⟹ normalized_nnf_match m ⟹ f m = Some m' ⟹ normalized_nnf_match m'"
and "⋀m m' f. f ∈ set fs ⟹ normalized_nnf_match m ⟹ P m ⟹ f m = Some m' ⟹ P m'"
and "normalized_nnf_match m"
and "P m"
and "(compress_normalize_primitive_monad fs m) = Some m'"
shows "normalized_nnf_match m' ∧ P m'"
using assms proof(induction fs arbitrary: m)
case Nil thus ?case by simp
next
case (Cons f fs) thus ?case by(simp split: option.split_asm) blast
qed
datatype 'a match_compress = CannotMatch | MatchesAll | MatchExpr 'a
end
Theory MatchExpr_Fold
section‹Combine Match Expressions›
theory MatchExpr_Fold
imports Primitive_Normalization
begin
fun andfold_MatchExp :: "'a match_expr list ⇒ 'a match_expr" where
"andfold_MatchExp [] = MatchAny" |
"andfold_MatchExp [e] = e" |
"andfold_MatchExp (e#es) = MatchAnd e (andfold_MatchExp es)"
lemma andfold_MatchExp_alist_and: "alist_and' (map Pos ls) = andfold_MatchExp (map Match ls)"
apply(induction ls)
apply(simp)
apply(simp)
apply(rename_tac l ls)
apply(case_tac "ls")
by(simp)+
lemma andfold_MatchExp_matches:
"matches γ (andfold_MatchExp ms) a p ⟷ (∀m ∈ set ms. matches γ m a p)"
apply(induction ms rule: andfold_MatchExp.induct)
apply(simp add: bunch_of_lemmata_about_matches)+
done
lemma andfold_MatchExp_not_discI:
"∀m ∈ set ms. ¬ has_disc disc m ⟹ ¬ has_disc disc (andfold_MatchExp ms)"
by(induction ms rule: andfold_MatchExp.induct) (simp)+
lemma andfold_MatchExp_not_disc_negatedI:
"∀m ∈ set ms. ¬ has_disc_negated disc neg m ⟹ ¬ has_disc_negated disc neg (andfold_MatchExp ms)"
by(induction ms rule: andfold_MatchExp.induct) (simp)+
lemma andfold_MatchExp_not_disc_negated_mapMatch:
"¬ has_disc_negated disc False (andfold_MatchExp (map (Match ∘ C) ls))"
apply(induction ls)
apply(simp; fail)
apply(simp)
apply(rename_tac ls, case_tac ls)
by(simp)+
lemma andfold_MatchExp_not_disc_mapMatch:
"∀a. ¬ disc (C a) ⟹ ¬ has_disc disc (andfold_MatchExp (map (Match ∘ C) ls))"
apply(induction ls)
apply(simp; fail)
apply(simp)
apply(rename_tac ls, case_tac ls)
by(simp)+
lemma andfold_MatchExp_normalized_nnf: "∀m ∈ set ms. normalized_nnf_match m ⟹
normalized_nnf_match (andfold_MatchExp ms)"
by(induction ms rule: andfold_MatchExp.induct)(simp)+
lemma andfold_MatchExp_normalized_n_primitive: "∀m ∈ set ms. normalized_n_primitive (disc, sel) f m ⟹
normalized_n_primitive (disc, sel) f (andfold_MatchExp ms)"
by(induction ms rule: andfold_MatchExp.induct)(simp)+
lemma andfold_MatchExp_normalized_normalized_n_primitive_single:
"∀a. ¬ disc (C a) ⟹
s ∈ set (normalize_match (andfold_MatchExp (map (Match ∘ C) xs))) ⟹
normalized_n_primitive (disc, sel) f s"
apply(rule normalized_n_primitive_if_no_primitive)
using normalized_nnf_match_normalize_match apply blast
apply(rule normalize_match_preserves_nodisc[where m="(andfold_MatchExp (map (Match ∘ C) xs))"])
apply simp_all
by (simp add: andfold_MatchExp_not_discI)
lemma normalize_andfold_MatchExp_normalized_n_primitive:
"∀ m ∈ set ms. ∀ s' ∈ set (normalize_match m). normalized_n_primitive (disc, sel) f s' ⟹
s ∈ set (normalize_match (andfold_MatchExp ms)) ⟹
normalized_n_primitive (disc, sel) f s"
proof(induction ms arbitrary: s rule: andfold_MatchExp.induct)
case 1 thus ?case by simp
next
case 2 thus ?case by simp
next
case (3 v1 v2 va)
have IH: "s' ∈ set (normalize_match (andfold_MatchExp (v2 # va))) ⟹
normalized_n_primitive (disc, sel) f s'" for s'
using 3(1)[of s']
apply(simp)
using 3(2) by force
from 3(2,3) IH show ?case by(clarsimp)
qed
end
Theory Common_Primitive_Lemmas
theory Common_Primitive_Lemmas
imports Common_Primitive_Matcher
"../Semantics_Ternary/Primitive_Normalization"
"../Semantics_Ternary/MatchExpr_Fold"
begin
section‹Further Lemmas about the Common Matcher›
lemma has_unknowns_common_matcher: fixes m::"'i::len common_primitive match_expr"
shows "has_unknowns common_matcher m ⟷ has_disc is_Extra m"
proof -
{ fix A and p :: "('i, 'a) tagged_packet_scheme"
have "common_matcher A p = TernaryUnknown ⟷ is_Extra A"
by(induction A p rule: common_matcher.induct) (simp_all add: bool_to_ternary_Unknown)
} hence "β = (common_matcher::('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac)
⟹ has_unknowns β m = has_disc is_Extra m" for β
by(induction β m rule: has_unknowns.induct)
(simp_all)
thus ?thesis by simp
qed
end
Theory Ports_Normalize
theory Ports_Normalize
imports Common_Primitive_Lemmas
begin
section‹Normalizing L4 Ports›
subsection‹Defining Normalized Ports›
fun normalized_src_ports :: "'i::len common_primitive match_expr ⇒ bool" where
"normalized_src_ports MatchAny = True" |
"normalized_src_ports (Match (Src_Ports (L4Ports _ []))) = True" |
"normalized_src_ports (Match (Src_Ports (L4Ports _ [_]))) = True" |
"normalized_src_ports (Match (Src_Ports _)) = False" |
"normalized_src_ports (Match _) = True" |
"normalized_src_ports (MatchNot (Match (Src_Ports _))) = False" |
"normalized_src_ports (MatchNot (Match _)) = True" |
"normalized_src_ports (MatchAnd m1 m2) = (normalized_src_ports m1 ∧ normalized_src_ports m2)" |
"normalized_src_ports (MatchNot (MatchAnd _ _)) = False" |
"normalized_src_ports (MatchNot (MatchNot _)) = False" |
"normalized_src_ports (MatchNot MatchAny) = True"
fun normalized_dst_ports :: "'i::len common_primitive match_expr ⇒ bool" where
"normalized_dst_ports MatchAny = True" |
"normalized_dst_ports (Match (Dst_Ports (L4Ports _ []))) = True" |
"normalized_dst_ports (Match (Dst_Ports (L4Ports _ [_]))) = True" |
"normalized_dst_ports (Match (Dst_Ports _)) = False" |
"normalized_dst_ports (Match _) = True" |
"normalized_dst_ports (MatchNot (Match (Dst_Ports _))) = False" |
"normalized_dst_ports (MatchNot (Match _)) = True" |
"normalized_dst_ports (MatchAnd m1 m2) = (normalized_dst_ports m1 ∧ normalized_dst_ports m2)" |
"normalized_dst_ports (MatchNot (MatchAnd _ _)) = False" |
"normalized_dst_ports (MatchNot (MatchNot _)) = False" |
"normalized_dst_ports (MatchNot MatchAny) = True"
lemma normalized_src_ports_def2: "normalized_src_ports ms = normalized_n_primitive (is_Src_Ports, src_ports_sel) (λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1) ms"
by(induction ms rule: normalized_src_ports.induct, simp_all)
lemma normalized_dst_ports_def2: "normalized_dst_ports ms = normalized_n_primitive (is_Dst_Ports, dst_ports_sel) (λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1) ms"
by(induction ms rule: normalized_dst_ports.induct, simp_all)
text‹Idea: first, remove all negated matches, then @{const normalize_match},
then only work with @{const primitive_extractor} on @{const Pos} ones.
They only need an intersect and split later on.
This is not very efficient because normalizing nnf will blow up a lot.
but we can tune performance later on go for correctness first!
Anything with @{const MatchOr} and @{const normalize_match} later is a bit inefficient.
›
subsection‹Compressing Positive Matches on Ports into a Single Match›
fun l4_ports_compress :: "ipt_l4_ports list ⇒ ipt_l4_ports match_compress" where
"l4_ports_compress [] = MatchesAll" |
"l4_ports_compress [L4Ports proto ps] = MatchExpr (L4Ports proto (wi2l (wordinterval_compress (l2wi ps))))" |
"l4_ports_compress (L4Ports proto1 ps1 # L4Ports proto2 ps2 # pss) =
(if
proto1 ≠ proto2
then
CannotMatch
else
l4_ports_compress (L4Ports proto1 (wi2l (wordinterval_intersection (l2wi ps1) (l2wi ps2))) # pss)
)"
value[code] "l4_ports_compress [L4Ports TCP [(22,22), (23,23)]]"
lemma raw_ports_compress_src_CannotMatch:
fixes p :: "('i::len, 'a) tagged_packet_scheme"
assumes generic: "primitive_matcher_generic β"
and c: "l4_ports_compress pss = CannotMatch"
shows "¬ matches (β, α) (alist_and (map (Pos ∘ Src_Ports) pss)) a p"
using c apply(induction pss rule: l4_ports_compress.induct)
apply(simp; fail)
apply(simp; fail)
apply(simp add: primitive_matcher_generic.Ports_single[OF generic] bunch_of_lemmata_about_matches split: if_split_asm)
apply meson
by(simp add: l2wi_wi2l ports_to_set_wordinterval)
lemma raw_ports_compress_dst_CannotMatch:
fixes p :: "('i::len, 'a) tagged_packet_scheme"
assumes generic: "primitive_matcher_generic β"
and c: "l4_ports_compress pss = CannotMatch"
shows "¬ matches (β, α) (alist_and (map (Pos ∘ Dst_Ports) pss)) a p"
using c apply(induction pss rule: l4_ports_compress.induct)
apply(simp; fail)
apply(simp; fail)
apply(simp add: primitive_matcher_generic.Ports_single[OF generic] bunch_of_lemmata_about_matches split: if_split_asm)
apply meson
by(simp add: l2wi_wi2l ports_to_set_wordinterval)
lemma l4_ports_compress_length_Matchall: "length pss > 0 ⟹ l4_ports_compress pss ≠ MatchesAll"
by(induction pss rule: l4_ports_compress.induct) simp+
lemma raw_ports_compress_MatchesAll:
fixes p :: "('i::len, 'a) tagged_packet_scheme"
assumes generic: "primitive_matcher_generic β"
and c: "l4_ports_compress pss = MatchesAll"
shows "matches (β, α) (alist_and (map (Pos ∘ Src_Ports) pss)) a p"
and "matches (β, α) (alist_and (map (Pos ∘ Dst_Ports) pss)) a p"
using c apply(induction pss rule: l4_ports_compress.induct)
by(simp add: l4_ports_compress_length_Matchall bunch_of_lemmata_about_matches split: if_split_asm)+
lemma raw_ports_compress_src_MatchExpr:
fixes p :: "('i::len, 'a) tagged_packet_scheme"
assumes generic: "primitive_matcher_generic β"
and c: "l4_ports_compress pss = MatchExpr m"
shows "matches (β, α) (Match (Src_Ports m)) a p ⟷ matches (β, α) (alist_and (map (Pos ∘ Src_Ports) pss)) a p"
using c apply(induction pss arbitrary: m rule: l4_ports_compress.induct)
apply(simp add: bunch_of_lemmata_about_matches; fail)
subgoal
apply(simp add: bunch_of_lemmata_about_matches)
apply(drule sym, simp)
by(simp add: primitive_matcher_generic.Ports_single[OF generic] wordinterval_compress l2wi_wi2l ports_to_set_wordinterval)
apply(case_tac m)
apply(simp add: bunch_of_lemmata_about_matches split: if_split_asm)
apply(simp add: primitive_matcher_generic.Ports_single[OF generic])
apply(simp add: l2wi_wi2l ports_to_set_wordinterval)
by fastforce
lemma raw_ports_compress_dst_MatchExpr:
fixes p :: "('i::len, 'a) tagged_packet_scheme"
assumes generic: "primitive_matcher_generic β"
and c: "l4_ports_compress pss = MatchExpr m"
shows "matches (β, α) (Match (Dst_Ports m)) a p ⟷ matches (β, α) (alist_and (map (Pos ∘ Dst_Ports) pss)) a p"
using c apply(induction pss arbitrary: m rule: l4_ports_compress.induct)
apply(simp add: bunch_of_lemmata_about_matches; fail)
subgoal
apply(simp add: bunch_of_lemmata_about_matches)
apply(drule sym, simp)
by(simp add: primitive_matcher_generic.Ports_single[OF generic] wordinterval_compress l2wi_wi2l ports_to_set_wordinterval)
apply(case_tac m)
apply(simp add: bunch_of_lemmata_about_matches split: if_split_asm)
apply(simp add: primitive_matcher_generic.Ports_single[OF generic])
apply(simp add: l2wi_wi2l ports_to_set_wordinterval)
by fastforce
subsection‹Rewriting Negated Matches on Ports›
fun l4_ports_negate_one
:: "(ipt_l4_ports ⇒ 'i common_primitive) ⇒ ipt_l4_ports ⇒ ('i::len common_primitive) match_expr"
where
"l4_ports_negate_one C (L4Ports proto pts) = MatchOr
(MatchNot (Match (Prot (Proto proto))))
(Match (C (L4Ports proto (raw_ports_invert pts))))"
lemma l4_ports_negate_one:
fixes p :: "('i::len, 'a) tagged_packet_scheme"
assumes generic: "primitive_matcher_generic β"
shows "matches (β, α) (l4_ports_negate_one Src_Ports ports) a p ⟷
matches (β, α) (MatchNot (Match (Src_Ports ports))) a p"
and "matches (β, α) (l4_ports_negate_one Dst_Ports ports) a p ⟷
matches (β, α) (MatchNot (Match (Dst_Ports ports))) a p"
apply(case_tac [!] ports)
by(auto simp add: primitive_matcher_generic.Ports_single_not[OF generic]
MatchOr bunch_of_lemmata_about_matches
primitive_matcher_generic.Prot_single_not[OF generic]
primitive_matcher_generic.Ports_single[OF generic]
raw_ports_invert)
lemma l4_ports_negate_one_nodisc:
"∀a. ¬ disc (C a) ⟹ ∀a. ¬ disc (Prot a) ⟹ ¬ has_disc disc (l4_ports_negate_one C pt)"
apply(cases pt)
by(simp add: MatchOr_def)
lemma l4_ports_negate_one_not_has_disc_negated_generic:
assumes noProt: "∀a. ¬ disc (Prot a)"
shows "¬ has_disc_negated disc False (l4_ports_negate_one C ports)"
apply(cases ports, rename_tac proto pts)
by(simp add: MatchOr_def noProt)
lemma l4_ports_negate_one_not_has_disc_negated:
"¬ has_disc_negated is_Src_Ports False (l4_ports_negate_one Src_Ports ports)"
"¬ has_disc_negated is_Dst_Ports False (l4_ports_negate_one Dst_Ports ports)"
by(simp add: l4_ports_negate_one_not_has_disc_negated_generic)+
lemma negated_normalized_folded_ports_nodisc:
"∀a. ¬ disc (C a) ⟹ (∀a. ¬ disc (Prot a)) ∨ pts = [] ⟹
m ∈ set (normalize_match (andfold_MatchExp (map (l4_ports_negate_one C) pts))) ⟹
¬ has_disc disc m"
apply(subgoal_tac "¬ has_disc disc (andfold_MatchExp (map (l4_ports_negate_one C) pts))")
prefer 2
apply(rule andfold_MatchExp_not_discI)
apply(simp)
apply(elim disjE)
using l4_ports_negate_one_nodisc apply blast
apply(simp; fail)
using normalize_match_preserves_nodisc by blast
lemma negated_normalized_folded_ports_normalized_n_primitive:
"∀a. ¬ disc (C a) ⟹ (∀a. ¬ disc (Prot a)) ∨ pts = [] ⟹
x ∈ set (normalize_match (andfold_MatchExp (map (l4_ports_negate_one C) pts))) ⟹
normalized_n_primitive (disc, sel) f x"
apply(rule normalized_n_primitive_if_no_primitive)
using normalized_nnf_match_normalize_match apply blast
apply(rule negated_normalized_folded_ports_nodisc)
by simp_all
text‹beware, the result is not nnf normalized!›
lemma "¬ normalized_nnf_match (l4_ports_negate_one C ports)"
by(cases ports) (simp add: MatchOr_def)
text‹Warning: does not preserve negated primitive property in general.
Might be violated for @{const Prot}. We will nnf normalize after applying the function.›
lemma "∀a. ¬ disc (C a) ⟹ ¬ normalized_n_primitive (disc, sel) f (l4_ports_negate_one C a)"
by(cases a)(simp add: MatchOr_def)
declare l4_ports_negate_one.simps[simp del]
lemma "((normalize_match (l4_ports_negate_one Src_Ports (L4Ports TCP [(22,22),(80,90)]))):: 32 common_primitive match_expr list)
=
[ MatchNot (Match (Prot (Proto TCP)))
, Match (Src_Ports (L4Ports 6 [(0, 21), (23, 79), (91, 0xFFFF)]))]" by eval
definition rewrite_negated_primitives
:: "(('a ⇒ bool) × ('a ⇒ 'b)) ⇒ ('b ⇒ 'a) ⇒
(('b ⇒ 'a) ⇒ 'b ⇒ 'a match_expr) ⇒
'a match_expr ⇒ 'a match_expr" where
"rewrite_negated_primitives disc_sel C negate m ≡
let (spts, rst) = primitive_extractor disc_sel m
in if getNeg spts = [] then m else
MatchAnd
(andfold_MatchExp (map (negate C) (getNeg spts)))
(MatchAnd
(andfold_MatchExp (map (Match ∘ C) (getPos spts)))
rst)"
text‹It does nothing of there is not even a negated primitive in it›
lemma rewrite_negated_primitives_unchanged_if_not_has_disc_negated:
assumes n: "normalized_nnf_match m"
and wf_disc_sel: "wf_disc_sel (disc,sel) C"
and noDisc: "¬ has_disc_negated disc False m"
shows "rewrite_negated_primitives (disc,sel) C negate_f m = m"
apply(simp add: rewrite_negated_primitives_def)
apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
apply(simp)
apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
using noDisc by blast
lemma rewrite_negated_primitives_normalized_no_modification:
assumes wf_disc_sel: "wf_disc_sel (disc, sel) C"
and disc_p: "¬ has_disc_negated disc False m"
and n: "normalized_nnf_match m"
and a: "a ∈ set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m))"
shows "a = m"
proof -
from rewrite_negated_primitives_unchanged_if_not_has_disc_negated[OF n wf_disc_sel disc_p]
have m: "rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m = m" by simp
from a show ?thesis
apply(subst(asm) m)
using normalize_match_already_normalized[OF n] by fastforce
qed
lemma rewrite_negated_primitives_preserves_not_has_disc:
assumes n: "normalized_nnf_match m"
and wf_disc_sel: "wf_disc_sel (disc, sel) C"
and nodisc: "¬ has_disc disc2 m"
and noNeg: "¬ has_disc_negated disc False m"
and disc2_noC: "∀a. ¬ disc2 (C a)"
shows "¬ has_disc disc2 (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)"
apply(subst rewrite_negated_primitives_unchanged_if_not_has_disc_negated)
using n wf_disc_sel noNeg nodisc by(simp)+
lemma rewrite_negated_primitives:
assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel disc_sel C"
and negate_f: "∀pts. matches γ (negate_f C pts) a p ⟷ matches γ (MatchNot (Match (C pts))) a p"
shows "matches γ (rewrite_negated_primitives disc_sel C negate_f m) a p ⟷ matches γ m a p"
proof -
obtain spts rst where pext: "primitive_extractor disc_sel m = (spts, rst)"
by(cases "primitive_extractor disc_sel m") simp
obtain disc sel where disc_sel: "disc_sel = (disc, sel)" by(cases disc_sel) simp
with wf_disc_sel have wf_disc_sel': "wf_disc_sel (disc, sel) C" by simp
from disc_sel pext have pext': "primitive_extractor (disc, sel) m = (spts, rst)" by simp
have "matches γ (andfold_MatchExp (map (negate_f C) (getNeg spts))) a p ∧
matches γ (andfold_MatchExp (map (Match ∘ C) (getPos spts))) a p ∧ matches γ rst a p ⟷
matches γ m a p"
apply(subst primitive_extractor_correct(1)[OF n wf_disc_sel' pext', symmetric])
apply(simp add: andfold_MatchExp_matches)
apply(simp add: negate_f)
using alist_and_NegPos_map_getNeg_getPos_matches by fast
thus ?thesis by(simp add: rewrite_negated_primitives_def pext bunch_of_lemmata_about_matches)
qed
lemma rewrite_negated_primitives_not_has_disc:
assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
and nodisc: "¬ has_disc disc2 m"
and negate_f: "has_disc_negated disc False m ⟹ ∀pts. ¬ has_disc disc2 (negate_f C pts)"
and no_disc: "∀a. ¬ disc2 (C a)"
shows "¬ has_disc disc2 (rewrite_negated_primitives (disc,sel) C negate_f m)"
apply(simp add: rewrite_negated_primitives_def)
apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
apply(simp)
apply(frule primitive_extractor_correct(4)[OF n wf_disc_sel])
apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
apply(intro conjI impI)
using nodisc apply(simp; fail)
apply(rule andfold_MatchExp_not_discI)
apply(simp add: negate_f; fail)
using andfold_MatchExp_not_disc_mapMatch no_disc apply blast
using nodisc by blast
lemma rewrite_negated_primitives_not_has_disc_negated:
assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
and negate_f: "has_disc_negated disc False m ⟹ ∀pts. ¬ has_disc_negated disc False (negate_f C pts)"
shows "¬ has_disc_negated disc False (rewrite_negated_primitives (disc,sel) C negate_f m)"
apply(simp add: rewrite_negated_primitives_def)
apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
apply(simp)
apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
apply(intro conjI impI)
apply blast
apply(rule andfold_MatchExp_not_disc_negatedI)
apply(simp add: negate_f; fail)
using andfold_MatchExp_not_disc_negated_mapMatch apply blast
using has_disc_negated_has_disc by blast
lemma rewrite_negated_primitives_preserves_not_has_disc_negated:
assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
and negate_f: "has_disc_negated disc False m ⟹ ∀pts. ¬ has_disc_negated disc2 False (negate_f C pts)"
and no_disc: "¬ has_disc_negated disc2 False m"
shows "¬ has_disc_negated disc2 False (rewrite_negated_primitives (disc,sel) C negate_f m)"
apply(simp add: rewrite_negated_primitives_def)
apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
apply(simp)
apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
apply(intro conjI impI)
using no_disc apply blast
apply(rule andfold_MatchExp_not_disc_negatedI)
apply(simp add: negate_f; fail)
using andfold_MatchExp_not_disc_negated_mapMatch apply blast
apply(drule primitive_extractor_correct(6)[OF n wf_disc_sel, where neg=False])
using no_disc by blast
lemma rewrite_negated_primitives_normalized_preserves_unrelated_helper:
assumes wf_disc_sel: "wf_disc_sel (disc, sel) C"
and disc: "∀a. ¬ disc2 (C a)"
and disc_p: "(∀a. ¬ disc2 (Prot a)) ∨ ¬ has_disc_negated disc False m"
shows "normalized_nnf_match m ⟹
normalized_n_primitive (disc2, sel2) f m ⟹
a ∈ set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)) ⟹
normalized_n_primitive (disc2, sel2) f a"
proof -
have helper_a_normalized: "a ∈ MatchAnd x ` (⋃x∈set spts. MatchAnd x ` set (normalize_match rst)) ⟹
normalized_n_primitive (disc, sel) f x ⟹
(∀s ∈ set spts. normalized_n_primitive (disc, sel) f s) ⟹
normalized_n_primitive (disc, sel) f rst ⟹
normalized_n_primitive (disc, sel) f a"
for a x spts rst f disc and sel::"'a common_primitive ⇒ 'b"
apply(subgoal_tac "∃ s r. a = MatchAnd x (MatchAnd s r) ∧ s ∈ set spts ∧ r ∈ set (normalize_match rst)")
prefer 2
apply blast
apply(elim exE conjE, rename_tac s r)
apply(simp)
using normalize_match_preserves_normalized_n_primitive by blast
show "normalized_nnf_match m ⟹
normalized_n_primitive (disc2, sel2) f m ⟹
a ∈ set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)) ⟹
normalized_n_primitive (disc2, sel2) f a"
apply(case_tac "¬ has_disc_negated disc False m")
subgoal
using rewrite_negated_primitives_normalized_no_modification[OF wf_disc_sel] by blast
apply(simp add: rewrite_negated_primitives_def)
apply(case_tac "primitive_extractor (disc, sel) m", rename_tac spts rst)
apply(simp)
apply(subgoal_tac "normalized_n_primitive (disc2, sel2) f rst")
prefer 2 subgoal for spts rst
apply(drule primitive_extractor_correct(5)[OF _ wf_disc_sel, where P="f"])
apply blast
by(simp)
apply(insert disc_p, simp)
apply(drule(1) primitive_extractor_correct(8)[OF _ wf_disc_sel])
apply(simp)
apply(elim bexE)
apply(erule helper_a_normalized)
subgoal for spts
apply(rule_tac pts="(getNeg spts)" in negated_normalized_folded_ports_normalized_n_primitive[where C=C])
using disc apply(simp; fail)
using disc_p primitive_extractor_correct(8)[OF _ wf_disc_sel] apply blast
by simp
subgoal for x
apply(intro ballI)
apply(rule andfold_MatchExp_normalized_normalized_n_primitive_single[where C=C])
using disc disc_p by(simp)+
by blast
qed
definition rewrite_negated_src_ports
:: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr" where
"rewrite_negated_src_ports m ≡
rewrite_negated_primitives (is_Src_Ports, src_ports_sel) Src_Ports l4_ports_negate_one m"
definition rewrite_negated_dst_ports
:: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr" where
"rewrite_negated_dst_ports m ≡
rewrite_negated_primitives (is_Dst_Ports, dst_ports_sel) Dst_Ports l4_ports_negate_one m"
value "rewrite_negated_src_ports (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
(MatchAnd (Match (Prot (Proto TCP)))
(MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
))"
value "rewrite_negated_src_ports (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
(MatchAnd (Match (Prot (Proto TCP)))
(MatchNot (Match (Extra ''foobar'')))
))"
lemma rewrite_negated_src_ports:
assumes generic: "primitive_matcher_generic β" and n: "normalized_nnf_match m"
shows "matches (β, α) (rewrite_negated_src_ports m) a p ⟷ matches (β, α) m a p"
apply(simp add: rewrite_negated_src_ports_def)
apply(rule rewrite_negated_primitives)
by(simp add: l4_ports_negate_one[OF generic] n wf_disc_sel_common_primitive(1))+
lemma rewrite_negated_dst_ports:
assumes generic: "primitive_matcher_generic β" and n: "normalized_nnf_match m"
shows "matches (β, α) (rewrite_negated_dst_ports m) a p ⟷ matches (β, α) m a p"
apply(simp add: rewrite_negated_dst_ports_def)
apply(rule rewrite_negated_primitives)
by(simp add: l4_ports_negate_one[OF generic] n wf_disc_sel_common_primitive(2))+
lemma rewrite_negated_src_ports_not_has_disc_negated:
assumes n: "normalized_nnf_match m"
shows "¬ has_disc_negated is_Src_Ports False (rewrite_negated_src_ports m)"
apply(simp add: rewrite_negated_src_ports_def)
apply(rule rewrite_negated_primitives_not_has_disc_negated)
by(simp add: n wf_disc_sel_common_primitive(1) l4_ports_negate_one_not_has_disc_negated)+
lemma rewrite_negated_dst_ports_not_has_disc_negated:
assumes n: "normalized_nnf_match m"
shows "¬ has_disc_negated is_Dst_Ports False (rewrite_negated_dst_ports m)"
apply(simp add: rewrite_negated_dst_ports_def)
apply(rule rewrite_negated_primitives_not_has_disc_negated)
by(simp add: n wf_disc_sel_common_primitive(2) l4_ports_negate_one_not_has_disc_negated)+
lemma "¬ has_disc_negated disc t m ⟹ ∀m' ∈ set (normalize_match m). ¬ has_disc_negated disc t m'"
by(fact i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day)
corollary normalize_rewrite_negated_src_ports_not_has_disc_negated:
assumes n: "normalized_nnf_match m"
shows "∀m' ∈ set (normalize_match (rewrite_negated_src_ports m)). ¬ has_disc_negated is_Src_Ports False m'"
apply(rule i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day)
apply(rule rewrite_negated_src_ports_not_has_disc_negated)
using n by simp
subsection‹Normalizing Positive Matches on Ports›
fun singletonize_L4Ports :: "ipt_l4_ports ⇒ ipt_l4_ports list" where
"singletonize_L4Ports (L4Ports proto pts) = map (λp. L4Ports proto [p]) pts"
lemma singletonize_L4Ports_src: assumes generic: "primitive_matcher_generic β"
shows "match_list (β, α) (map (Match ∘ Src_Ports) (singletonize_L4Ports pts)) a p ⟷
matches (β, α) (Match (Src_Ports pts)) a p"
apply(cases pts)
apply(simp add: match_list_matches primitive_matcher_generic.Ports_single[OF generic])
apply(simp add: ports_to_set)
by auto
lemma singletonize_L4Ports_dst: assumes generic: "primitive_matcher_generic β"
shows "match_list (β, α) (map (Match ∘ Dst_Ports) (singletonize_L4Ports pts)) a p ⟷
matches (β, α) (Match (Dst_Ports pts)) a p"
apply(cases pts)
apply(simp add: match_list_matches primitive_matcher_generic.Ports_single[OF generic])
apply(simp add: ports_to_set)
by auto
lemma singletonize_L4Ports_normalized_generic:
assumes wf_disc_sel: "wf_disc_sel (disc,sel) C"
and "m' ∈ (λspt. Match (C spt)) ` set (singletonize_L4Ports pt)"
shows "normalized_n_primitive (disc, sel) (case_ipt_l4_ports (λx pts. length pts ≤ 1)) m'"
using assms
apply(case_tac pt)
apply(simp)
apply(induction m')
by(auto simp: wf_disc_sel.simps)
lemma singletonize_L4Ports_normalized_src_ports:
"m' ∈ (λspt. Match (Src_Ports spt)) ` set (singletonize_L4Ports pt) ⟹ normalized_src_ports m'"
apply(simp add: normalized_src_ports_def2)
using singletonize_L4Ports_normalized_generic[OF wf_disc_sel_common_primitive(1)] by blast
lemma singletonize_L4Ports_normalized_dst_ports:
"m' ∈ (λspt. Match (Dst_Ports spt)) ` set (singletonize_L4Ports pt) ⟹ normalized_dst_ports m'"
apply(simp add: normalized_dst_ports_def2)
using singletonize_L4Ports_normalized_generic[OF wf_disc_sel_common_primitive(2)] by blast
declare singletonize_L4Ports.simps[simp del]
lemma normalized_ports_singletonize_combine_rst:
assumes wf_disc_sel: "wf_disc_sel (disc,sel) C"
shows "normalized_n_primitive (disc, sel) (case_ipt_l4_ports (λx pts. length pts ≤ 1)) rst ⟹
m' ∈ (λspt. MatchAnd (Match (C spt)) rst) ` set (singletonize_L4Ports pt) ⟹
normalized_n_primitive (disc, sel) (case_ipt_l4_ports (λx pts. length pts ≤ 1)) m'"
apply simp
apply(rule normalized_n_primitive_MatchAnd_combine_map)
apply(simp_all)
using singletonize_L4Ports_normalized_generic[OF wf_disc_sel] by fastforce
text‹Normalizing match expressions such that at most one port will exist in it.
Returns a list of match expressions (splits one firewall rule into several rules).›
definition normalize_positive_ports_step
:: "(('i::len common_primitive ⇒ bool) × ('i common_primitive ⇒ ipt_l4_ports)) ⇒
(ipt_l4_ports ⇒ 'i common_primitive) ⇒
'i common_primitive match_expr ⇒ 'i common_primitive match_expr list" where
"normalize_positive_ports_step disc_sel C m ≡
let (spts, rst) = primitive_extractor disc_sel m in
case (getPos spts, getNeg spts)
of (pspts, []) ⇒ (case l4_ports_compress pspts of CannotMatch ⇒ []
| MatchesAll ⇒ [rst]
| MatchExpr m ⇒ map (λspt. (MatchAnd (Match (C spt)) rst)) (singletonize_L4Ports m)
)
| (_, _) ⇒ undefined"
lemma normalize_positive_ports_step_nnf:
assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
and noneg: "¬ has_disc_negated disc False m"
shows "m' ∈ set (normalize_positive_ports_step (disc,sel) C m) ⟹ normalized_nnf_match m'"
apply(simp add: normalize_positive_ports_step_def)
apply(elim exE conjE, rename_tac rst spts)
apply(drule sym)
apply(frule primitive_extractor_correct(2)[OF n wf_disc_sel])
apply(subgoal_tac "getNeg spts = []")
prefer 2 subgoal
apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel])
using noneg by simp+
apply(simp split: match_compress.split_asm)
by fastforce
lemma normalize_positive_ports_step_normalized_n_primitive:
assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
and noneg: "¬ has_disc_negated disc False m"
shows "∀m' ∈ set (normalize_positive_ports_step (disc,sel) C m).
normalized_n_primitive (disc,sel) (λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1) m'"
unfolding normalize_positive_ports_step_def
apply(intro ballI, rename_tac m')
apply(simp)
apply(elim exE conjE, rename_tac rst spts)
apply(drule sym)
apply(frule primitive_extractor_correct(2)[OF n wf_disc_sel])
apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
apply(subgoal_tac "getNeg spts = []")
prefer 2 subgoal
apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel])
using noneg by simp+
apply(subgoal_tac "normalized_n_primitive (disc,sel) (λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1) rst")
prefer 2 subgoal
by(drule(2) normalized_n_primitive_if_no_primitive)
apply(simp split: match_compress.split_asm)
using normalized_ports_singletonize_combine_rst[OF wf_disc_sel] by blast
definition normalize_positive_src_ports :: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr list" where
"normalize_positive_src_ports = normalize_positive_ports_step (is_Src_Ports, src_ports_sel) Src_Ports"
definition normalize_positive_dst_ports :: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr list" where
"normalize_positive_dst_ports = normalize_positive_ports_step (is_Dst_Ports, dst_ports_sel) Dst_Ports"
lemma noNeg_mapNegPos_helper: "getNeg ls = [] ⟹
map (Pos ∘ C) (getPos ls) = NegPos_map C ls"
by(induction ls rule: getPos.induct) simp+
lemma normalize_positive_src_ports:
assumes generic: "primitive_matcher_generic β"
and n: "normalized_nnf_match m"
and noneg: "¬ has_disc_negated is_Src_Ports False m"
shows
"match_list (β, α) (normalize_positive_src_ports m) a p ⟷ matches (β, α) m a p"
apply(simp add: normalize_positive_src_ports_def normalize_positive_ports_step_def)
apply(case_tac "primitive_extractor (is_Src_Ports, src_ports_sel) m", rename_tac spts rst)
apply(simp)
apply(subgoal_tac "getNeg spts = []")
prefer 2 subgoal
apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel_common_primitive(1)])
using noneg by simp+
apply(simp)
apply(drule primitive_extractor_correct(1)[OF n wf_disc_sel_common_primitive(1), where γ="(β, α)" and a=a and p=p])
apply(case_tac "l4_ports_compress (getPos spts)")
apply(simp)
apply(drule raw_ports_compress_src_CannotMatch[OF generic, where α=α and a=a and p=p])
apply(simp add: noNeg_mapNegPos_helper; fail)
apply(simp)
apply(drule raw_ports_compress_MatchesAll[OF generic, where α=α and a=a and p=p])
apply(simp add: noNeg_mapNegPos_helper; fail)
apply(simp add: bunch_of_lemmata_about_matches)
apply(drule raw_ports_compress_src_MatchExpr[OF generic, where α=α and a=a and p=p])
apply(insert singletonize_L4Ports_src[OF generic, where α=α and a=a and p=p])
apply(simp add: match_list_matches)
apply(simp add: bunch_of_lemmata_about_matches)
apply(simp add: noNeg_mapNegPos_helper; fail)
done
lemma normalize_positive_dst_ports:
assumes generic: "primitive_matcher_generic β"
and n: "normalized_nnf_match m"
and noneg: "¬ has_disc_negated is_Dst_Ports False m"
shows "match_list (β, α) (normalize_positive_dst_ports m) a p ⟷ matches (β, α) m a p"
apply(simp add: normalize_positive_dst_ports_def normalize_positive_ports_step_def)
apply(case_tac "primitive_extractor (is_Dst_Ports, dst_ports_sel) m", rename_tac spts rst)
apply(simp)
apply(subgoal_tac "getNeg spts = []")
prefer 2 subgoal
apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel_common_primitive(2)])
using noneg by simp+
apply(simp)
apply(drule primitive_extractor_correct(1)[OF n wf_disc_sel_common_primitive(2), where γ="(β, α)" and a=a and p=p])
apply(case_tac "l4_ports_compress (getPos spts)")
apply(simp)
apply(drule raw_ports_compress_dst_CannotMatch[OF generic, where α=α and a=a and p=p])
apply(simp add: noNeg_mapNegPos_helper; fail)
apply(simp)
apply(drule raw_ports_compress_MatchesAll(2)[OF generic, where α=α and a=a and p=p])
apply(simp add: noNeg_mapNegPos_helper; fail)
apply(simp add: bunch_of_lemmata_about_matches)
apply(drule raw_ports_compress_dst_MatchExpr[OF generic, where α=α and a=a and p=p])
apply(insert singletonize_L4Ports_dst[OF generic, where α=α and a=a and p=p])
apply(simp add: match_list_matches)
apply(simp add: bunch_of_lemmata_about_matches)
apply(simp add: noNeg_mapNegPos_helper; fail)
done
lemma normalize_positive_src_ports_nnf:
assumes n: "normalized_nnf_match m"
and noneg: "¬ has_disc_negated is_Src_Ports False m"
shows "m' ∈ set (normalize_positive_src_ports m) ⟹ normalized_nnf_match m'"
apply(rule normalize_positive_ports_step_nnf[OF n wf_disc_sel_common_primitive(1) noneg])
by(simp add: normalize_positive_src_ports_def)
lemma normalize_positive_dst_ports_nnf:
assumes n: "normalized_nnf_match m"
and noneg: "¬ has_disc_negated is_Dst_Ports False m"
shows "m' ∈ set (normalize_positive_dst_ports m) ⟹ normalized_nnf_match m'"
apply(rule normalize_positive_ports_step_nnf[OF n wf_disc_sel_common_primitive(2) noneg])
by(simp add: normalize_positive_dst_ports_def)
lemma normalize_positive_src_ports_normalized_n_primitive:
assumes n: "normalized_nnf_match m"
and noneg: "¬ has_disc_negated is_Src_Ports False m"
shows "∀m' ∈ set (normalize_positive_src_ports m). normalized_src_ports m'"
unfolding normalized_src_ports_def2
unfolding normalize_positive_src_ports_def
using normalize_positive_ports_step_normalized_n_primitive[OF n wf_disc_sel_common_primitive(1) noneg] by blast
lemma normalize_positive_dst_ports_normalized_n_primitive:
assumes n: "normalized_nnf_match m"
and noneg: "¬ has_disc_negated is_Dst_Ports False m"
shows "∀m' ∈ set (normalize_positive_dst_ports m). normalized_dst_ports m'"
unfolding normalized_dst_ports_def2
unfolding normalize_positive_dst_ports_def
using normalize_positive_ports_step_normalized_n_primitive[OF n wf_disc_sel_common_primitive(2) noneg] by blast
subsection‹Complete Normalization›
definition normalize_ports_generic
:: "('i common_primitive match_expr ⇒ 'i common_primitive match_expr list) ⇒
('i common_primitive match_expr ⇒ 'i common_primitive match_expr) ⇒
'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr list"
where
"normalize_ports_generic normalize_pos rewrite_neg m = concat (map normalize_pos (normalize_match (rewrite_neg m)))"
lemma normalize_ports_generic_nnf:
assumes n: "normalized_nnf_match m"
and inset: "m' ∈ set (normalize_ports_generic normalize_pos rewrite_neg m)"
and noNeg: "¬ has_disc_negated disc False (rewrite_neg m)"
and normalize_nnf_pos: "⋀m m'.
normalized_nnf_match m ⟹ ¬ has_disc_negated disc False m ⟹
m' ∈ set (normalize_pos m) ⟹ normalized_nnf_match m'"
shows "normalized_nnf_match m'"
using inset apply(simp add: normalize_ports_generic_def)
apply(elim bexE, rename_tac a)
apply(subgoal_tac "normalized_nnf_match a")
prefer 2
using normalized_nnf_match_normalize_match apply blast
apply(erule normalize_nnf_pos, simp_all)
apply(rule not_has_disc_normalize_match)
using noNeg n by blast+
lemma normalize_ports_generic:
assumes n: "normalized_nnf_match m"
and normalize_pos: "⋀m. normalized_nnf_match m ⟹ ¬ has_disc_negated disc False m ⟹
match_list γ (normalize_pos m) a p ⟷ matches γ m a p"
and rewrite_neg: "⋀m. normalized_nnf_match m ⟹
matches γ (rewrite_neg m) a p = matches γ m a p"
and noNeg: "⋀m. normalized_nnf_match m ⟹ ¬ has_disc_negated disc False (rewrite_neg m)"
shows
"match_list γ (normalize_ports_generic normalize_pos rewrite_neg m) a p ⟷ matches γ m a p"
unfolding normalize_ports_generic_def
proof
have 1: "ls ∈ set (normalize_match (rewrite_neg m)) ⟹
match_list γ (normalize_pos ls) a p ⟹ normalized_nnf_match ls ⟹ matches γ m a p"
for ls
apply(subst(asm) normalize_pos)
subgoal using normalized_nnf_match_normalize_match by blast
subgoal apply(rule_tac m="rewrite_neg m" in not_has_disc_normalize_match)
using noNeg n apply blast
by blast
apply(subgoal_tac "matches γ (rewrite_neg m) a p")
using rewrite_neg[OF n] apply blast
using in_normalized_matches[where γ=γ and a=a and p=p] by blast
show "match_list γ (concat (map normalize_pos (normalize_match (rewrite_neg m)))) a p ⟹ matches γ m a p"
apply(simp add: match_list_concat)
apply(clarify, rename_tac ls)
apply(subgoal_tac "normalized_nnf_match ls")
using 1 apply(simp; fail)
using normalized_nnf_match_normalize_match by blast
next
have 1: "ls ∈ set (normalize_match (rewrite_neg m)) ⟹
matches γ ls a p ⟹
normalized_nnf_match ls ⟹
match_list γ (concat (map normalize_pos (normalize_match (rewrite_neg m)))) a p" for ls
apply(simp add: match_list_concat)
apply(rule_tac x=ls in bexI)
prefer 2 apply(simp; fail)
apply(subst normalize_pos)
apply(simp_all)
apply(rule_tac m="rewrite_neg m" in not_has_disc_normalize_match)
using noNeg n apply blast
by blast
show "matches γ m a p ⟹ match_list γ (concat (map normalize_pos (normalize_match (rewrite_neg m)))) a p"
apply(subst(asm) rewrite_neg[OF n, symmetric])
apply(subst(asm) matches_to_match_list_normalize)
apply(subst(asm) match_list_matches)
apply(elim bexE, rename_tac ls)
apply(subgoal_tac "normalized_nnf_match ls")
using 1 apply blast
using normalized_nnf_match_normalize_match by blast
qed
lemma normalize_ports_generic_normalized_n_primitive:
assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
and noNeg: "⋀m. normalized_nnf_match m ⟹ ¬ has_disc_negated disc False (rewrite_neg m)"
and normalize_nnf_pos: "⋀m m'.
normalized_nnf_match m ⟹ ¬ has_disc_negated disc False m ⟹
m' ∈ set (normalize_pos m) ⟹ normalized_nnf_match m'"
and normalize_pos: "⋀m m'.
normalized_nnf_match m ⟹ ¬ has_disc_negated disc False m ⟹
∀m'∈set (normalize_pos m).
normalized_n_primitive (disc,sel) (λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1) m'"
shows "∀m' ∈ set (normalize_ports_generic normalize_pos rewrite_neg m).
normalized_n_primitive (disc,sel) (λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1) m'"
unfolding normalize_ports_generic_def
apply(intro ballI, rename_tac m')
apply(simp)
apply(elim bexE, rename_tac a)
apply(subgoal_tac "normalized_nnf_match a")
prefer 2
using normalized_nnf_match_normalize_match apply blast
apply(subgoal_tac "¬ has_disc_negated disc False a")
prefer 2
subgoal for ls
apply(rule_tac m="rewrite_neg m" in not_has_disc_normalize_match)
using noNeg n apply blast
by blast
apply(subgoal_tac "normalized_nnf_match m'")
prefer 2
using normalize_nnf_pos apply blast
using normalize_pos by blast
lemma normalize_ports_generic_normalize_positive_ports_step_erule:
assumes n: "normalized_nnf_match m"
and wf_disc_sel: "wf_disc_sel (disc, sel) C"
and noProt: "∀a. ¬ disc (Prot a)"
and P: "P (disc2, sel2) m"
and P1: "⋀a. normalized_nnf_match a ⟹
a ∈ set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)) ⟹
P (disc2, sel2) a"
and P2: "⋀a dpts rst. normalized_nnf_match a ⟹
primitive_extractor (disc, sel) a = (dpts, rst) ⟹
getNeg dpts = [] ⟹ P (disc2, sel2) a ⟹ P (disc2, sel2) rst"
and P3: "⋀ a spt rst. P (disc2, sel2) rst ⟹ P (disc2, sel2) (MatchAnd (Match (C spt)) rst)"
shows "m' ∈ set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m) ⟹
P (disc2, sel2) m'"
using P apply(simp add: normalize_ports_generic_def)
apply(elim bexE, rename_tac a)
apply(subgoal_tac "normalized_nnf_match a")
prefer 2 using normalized_nnf_match_normalize_match apply blast
apply(simp add: normalize_positive_ports_step_def)
apply(elim exE conjE, rename_tac rst dpts)
apply(drule sym)
apply(subgoal_tac "getNeg dpts = []")
prefer 2 subgoal for a rst dpts
apply(erule iffD1[OF primitive_extractor_correct(8)[OF _ wf_disc_sel]])
apply(simp; fail)
apply(rule not_has_disc_normalize_match)
apply(simp_all)
apply(rule rewrite_negated_primitives_not_has_disc_negated[OF n wf_disc_sel])
apply(intro allI)
apply(rule l4_ports_negate_one_not_has_disc_negated_generic)
by(simp add: noProt)
apply(subgoal_tac "P (disc2, sel2) a")
prefer 2 subgoal
apply(rule P1)
by(simp)
apply(frule_tac a=a in P2)
apply blast+
apply(simp split: match_compress.split_asm)
using P3 by auto
lemma normalize_ports_generic_preserves_normalized_n_primitive:
assumes n: "normalized_nnf_match m"
and wf_disc_sel: "wf_disc_sel (disc, sel) C"
and noProt: "∀a. ¬ disc (Prot a)"
and disc2_noC: "∀a. ¬ disc2 (C a)"
and disc2_noProt: "(∀a. ¬ disc2 (Prot a)) ∨ ¬ has_disc_negated disc False m"
shows "m' ∈ set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m) ⟹
normalized_n_primitive (disc2, sel2) f m ⟹
normalized_n_primitive (disc2, sel2) f m'"
thm normalize_ports_generic_normalize_positive_ports_step_erule
apply(rule normalize_ports_generic_normalize_positive_ports_step_erule[OF n wf_disc_sel noProt])
apply(simp_all add: disc2_noC disc2_noProt)
apply(rule rewrite_negated_primitives_normalized_preserves_unrelated_helper[OF wf_disc_sel _ _ n])
apply(simp_all add: disc2_noC disc2_noProt)
apply(frule_tac m=a in primitive_extractor_correct(5)[OF _ wf_disc_sel, where P=f])
by blast+
lemma normalize_ports_generic_preserves_normalized_not_has_disc:
assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc disc2 m"
and wf_disc_sel: "wf_disc_sel (disc, sel) C"
and noProt: "∀a. ¬ disc (Prot a)"
and disc2_noC: "∀a. ¬ disc2 (C a)"
and disc2_noProt: "(∀a. ¬ disc2 (Prot a)) ∨ ¬ has_disc_negated disc False m"
shows "m'∈ set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m)
⟹ ¬ has_disc disc2 m'"
apply(rule normalize_ports_generic_normalize_positive_ports_step_erule[OF n wf_disc_sel noProt])
apply(simp_all add: disc2_noC disc2_noProt nodisc)
subgoal for a
thm normalize_match_preserves_nodisc
apply(rule_tac m="rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m" in normalize_match_preserves_nodisc)
apply(simp_all)
apply(insert disc2_noProt)
apply(elim disjE)
thm rewrite_negated_primitives_not_has_disc[of _ disc2]
subgoal apply(rule rewrite_negated_primitives_not_has_disc[OF n wf_disc_sel nodisc _ disc2_noC])
using l4_ports_negate_one_nodisc[OF disc2_noC] by blast
using rewrite_negated_primitives_preserves_not_has_disc[OF n wf_disc_sel nodisc _ disc2_noC] by blast
apply(frule_tac m=a in primitive_extractor_correct(4)[OF _ wf_disc_sel])
by blast+
lemma normalize_ports_generic_preserves_normalized_not_has_disc_negated:
assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc_negated disc2 False m"
and wf_disc_sel: "wf_disc_sel (disc, sel) C"
and noProt: "∀a. ¬ disc (Prot a)"
and disc2_noProt: "(∀a. ¬ disc2 (Prot a)) ∨ ¬ has_disc_negated disc False m"
shows "m'∈ set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m)
⟹ ¬ has_disc_negated disc2 False m'"
apply(rule normalize_ports_generic_normalize_positive_ports_step_erule[OF n wf_disc_sel noProt])
apply(simp_all add: disc2_noProt nodisc)
subgoal for a
apply(rule_tac m="rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m" in not_has_disc_normalize_match)
apply(simp_all)
apply(rule rewrite_negated_primitives_preserves_not_has_disc_negated[OF n wf_disc_sel ])
using disc2_noProt l4_ports_negate_one_not_has_disc_negated_generic apply blast
using nodisc by blast
subgoal for a dpts rst
apply(frule_tac m=a and as=dpts and ms=rst and neg=False in primitive_extractor_correct(6)[OF _ wf_disc_sel])
by blast+
done
definition normalize_src_ports
:: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr list"
where
"normalize_src_ports m = normalize_ports_generic normalize_positive_src_ports rewrite_negated_src_ports m"
definition normalize_dst_ports
:: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr list"
where
"normalize_dst_ports m = normalize_ports_generic normalize_positive_dst_ports rewrite_negated_dst_ports m"
lemma normalize_src_ports:
assumes generic: "primitive_matcher_generic β"
and n: "normalized_nnf_match m"
shows "match_list (β, α) (normalize_src_ports m) a p ⟷ matches (β, α) m a p"
apply(simp add: normalize_src_ports_def)
apply(rule normalize_ports_generic[OF n])
using normalize_positive_src_ports[OF generic]
rewrite_negated_src_ports[OF generic, where α=α and a=a and p=p]
rewrite_negated_src_ports_not_has_disc_negated by blast+
lemma normalize_dst_ports:
assumes generic: "primitive_matcher_generic β"
and n: "normalized_nnf_match m"
shows "match_list (β, α) (normalize_dst_ports m) a p ⟷ matches (β, α) m a p"
apply(simp add: normalize_dst_ports_def)
apply(rule normalize_ports_generic[OF n])
using normalize_positive_dst_ports[OF generic]
rewrite_negated_dst_ports[OF generic, where α=α and a=a and p=p]
rewrite_negated_dst_ports_not_has_disc_negated by blast+
lemma normalize_src_ports_normalized_n_primitive:
assumes n:"normalized_nnf_match m"
shows "∀m' ∈ set (normalize_src_ports m). normalized_src_ports m'"
unfolding normalize_src_ports_def normalized_src_ports_def2
apply(rule normalize_ports_generic_normalized_n_primitive[OF n wf_disc_sel_common_primitive(1)])
using rewrite_negated_src_ports_not_has_disc_negated apply blast
using normalize_positive_src_ports_nnf apply blast
unfolding normalized_src_ports_def2[symmetric]
using normalize_positive_src_ports_normalized_n_primitive by blast
lemma normalize_dst_ports_normalized_n_primitive:
assumes n: "normalized_nnf_match m"
shows "∀m' ∈ set (normalize_dst_ports m). normalized_dst_ports m'"
unfolding normalize_dst_ports_def normalized_dst_ports_def2
apply(rule normalize_ports_generic_normalized_n_primitive[OF n wf_disc_sel_common_primitive(2)])
using rewrite_negated_dst_ports_not_has_disc_negated apply blast
using normalize_positive_dst_ports_nnf apply blast
unfolding normalized_dst_ports_def2[symmetric]
using normalize_positive_dst_ports_normalized_n_primitive by blast
lemma normalize_src_ports_nnf:
assumes n: "normalized_nnf_match m"
shows "m' ∈ set (normalize_src_ports m) ⟹ normalized_nnf_match m'"
apply(simp add: normalize_src_ports_def)
apply(erule normalize_ports_generic_nnf[OF n])
using n rewrite_negated_src_ports_not_has_disc_negated apply blast
using normalize_positive_src_ports_nnf by blast
lemma normalize_dst_ports_nnf:
assumes n: "normalized_nnf_match m"
shows "m' ∈ set (normalize_dst_ports m) ⟹ normalized_nnf_match m'"
apply(simp add: normalize_dst_ports_def)
apply(erule normalize_ports_generic_nnf[OF n])
using n rewrite_negated_dst_ports_not_has_disc_negated apply blast
using normalize_positive_dst_ports_nnf by blast
lemma normalize_src_ports_preserves_normalized_n_primitive:
assumes n: "normalized_nnf_match m"
and disc2_noC: "∀a. ¬ disc2 (Src_Ports a)"
and disc2_noProt: "(∀a. ¬ disc2 (Prot a)) ∨ ¬ has_disc_negated is_Src_Ports False m"
shows "m' ∈ set (normalize_src_ports m) ⟹
normalized_n_primitive (disc2, sel2) f m ⟹
normalized_n_primitive (disc2, sel2) f m'"
apply(rule normalize_ports_generic_preserves_normalized_n_primitive[OF n wf_disc_sel_common_primitive(1)])
by(simp_all add: disc2_noC disc2_noProt normalize_src_ports_def normalize_ports_generic_def
normalize_positive_src_ports_def rewrite_negated_src_ports_def)
lemma normalize_dst_ports_preserves_normalized_n_primitive:
assumes n: "normalized_nnf_match m"
and disc2_noC: "∀a. ¬ disc2 (Dst_Ports a)"
and disc2_noProt: "(∀a. ¬ disc2 (Prot a)) ∨ ¬ has_disc_negated is_Dst_Ports False m"
shows "m' ∈ set (normalize_dst_ports m) ⟹
normalized_n_primitive (disc2, sel2) f m ⟹
normalized_n_primitive (disc2, sel2) f m'"
apply(rule normalize_ports_generic_preserves_normalized_n_primitive[OF n wf_disc_sel_common_primitive(2)])
by(simp_all add: disc2_noC disc2_noProt normalize_dst_ports_def normalize_ports_generic_def
normalize_positive_dst_ports_def rewrite_negated_dst_ports_def)
lemma normalize_src_ports_preserves_normalized_not_has_disc:
assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc disc2 m"
and disc2_noC: "∀a. ¬ disc2 (Src_Ports a)"
and disc2_noProt: "(∀a. ¬ disc2 (Prot a)) ∨ ¬ has_disc_negated is_Src_Ports False m"
shows "m'∈ set (normalize_src_ports m)
⟹ ¬ has_disc disc2 m'"
apply(rule normalize_ports_generic_preserves_normalized_not_has_disc[OF n nodisc wf_disc_sel_common_primitive(1)])
apply(simp add: disc2_noC disc2_noProt)+
by (simp add: normalize_ports_generic_def normalize_positive_src_ports_def normalize_src_ports_def rewrite_negated_src_ports_def)
lemma normalize_dst_ports_preserves_normalized_not_has_disc:
assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc disc2 m"
and disc2_noC: "∀a. ¬ disc2 (Dst_Ports a)"
and disc2_noProt: "(∀a. ¬ disc2 (Prot a)) ∨ ¬ has_disc_negated is_Dst_Ports False m"
shows "m'∈ set (normalize_dst_ports m)
⟹ ¬ has_disc disc2 m'"
apply(rule normalize_ports_generic_preserves_normalized_not_has_disc[OF n nodisc wf_disc_sel_common_primitive(2)])
apply(simp add: disc2_noC disc2_noProt)+
by (simp add: normalize_ports_generic_def normalize_positive_dst_ports_def normalize_dst_ports_def rewrite_negated_dst_ports_def)
lemma normalize_src_ports_preserves_normalized_not_has_disc_negated:
assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc_negated disc2 False m"
and disc2_noProt: "(∀a. ¬ disc2 (Prot a)) ∨ ¬ has_disc_negated is_Src_Ports False m"
shows "m'∈ set (normalize_src_ports m)
⟹ ¬ has_disc_negated disc2 False m'"
apply(rule normalize_ports_generic_preserves_normalized_not_has_disc_negated[OF n nodisc wf_disc_sel_common_primitive(1)])
apply(simp add: disc2_noProt)+
by (simp add: normalize_ports_generic_def normalize_positive_src_ports_def normalize_src_ports_def rewrite_negated_src_ports_def)
lemma normalize_dst_ports_preserves_normalized_not_has_disc_negated:
assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc_negated disc2 False m"
and disc2_noProt: "(∀a. ¬ disc2 (Prot a)) ∨ ¬ has_disc_negated is_Dst_Ports False m"
shows "m'∈ set (normalize_dst_ports m)
⟹ ¬ has_disc_negated disc2 False m'"
apply(rule normalize_ports_generic_preserves_normalized_not_has_disc_negated[OF n nodisc wf_disc_sel_common_primitive(2)])
apply(simp add: disc2_noProt)+
by (simp add: normalize_ports_generic_def normalize_positive_dst_ports_def normalize_dst_ports_def rewrite_negated_dst_ports_def)
value[code] "normalize_src_ports
(MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
(MatchAnd (Match (Prot (Proto TCP)))
(MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
))"
lemma "map opt_MatchAny_match_expr (normalize_src_ports
(MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
(MatchAnd (Match (Prot (Proto TCP)))
(MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
))) =
[MatchAnd (MatchNot (Match (Prot (Proto UDP)))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto TCP)))),
MatchAnd (Match (Src_Ports (L4Ports UDP [(0, 79)]))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto TCP)))),
MatchAnd (Match (Src_Ports (L4Ports UDP [(81, 0xFFFF)]))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto TCP))))]" by eval
lemma "map opt_MatchAny_match_expr (normalize_src_ports
(MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
(MatchAnd (Match (Prot (Proto ICMP)))
(MatchAnd (Match (Src_Ports (L4Ports TCP [(22,22)])))
(MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
))))
=
[MatchAnd (Match (Src_Ports (L4Ports TCP [(22, 22)])))
(MatchAnd (MatchNot (Match (Prot (Proto UDP)))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto ICMP)))))]" by eval
lemma "map opt_MatchAny_match_expr (normalize_src_ports
(MatchAnd (Match ((Src_Ports (L4Ports UDP [(21,21), (22,22)])) :: 32 common_primitive))
(Match (Prot (Proto UDP)))))
=
[MatchAnd (Match (Src_Ports (L4Ports UDP [(21, 22)]))) (Match (Prot (Proto UDP)))]" by eval
lemma "normalize_match (andfold_MatchExp (map (l4_ports_negate_one C) [])) = [MatchAny]" by(simp)
definition replace_primitive_matchexpr
:: "(('a ⇒ bool) × ('a ⇒ 'b)) ⇒
('b negation_type ⇒ 'a match_expr) ⇒
'a match_expr ⇒ 'a match_expr" where
"replace_primitive_matchexpr disc_sel replace_f m ≡
let (as, rst) = primitive_extractor disc_sel m
in if as = [] then m else
MatchAnd
(andfold_MatchExp (map replace_f as))
rst"
text‹It does nothing of there is not even a primitive in it›
lemma replace_primitive_matchexpr_unchanged_if_not_has_disc:
assumes n: "normalized_nnf_match m"
and wf_disc_sel: "wf_disc_sel (disc,sel) C"
and noDisc: "¬ has_disc disc m"
shows "replace_primitive_matchexpr (disc,sel) replace_f m = m"
apply(simp add: replace_primitive_matchexpr_def)
apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
apply(simp)
apply(frule primitive_extractor_correct(7)[OF n wf_disc_sel])
using noDisc by blast+
lemma replace_primitive_matchexpr:
assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel disc_sel C"
and replace_f: "∀pt. matches γ (replace_f pt) a p ⟷
matches γ (negation_type_to_match_expr_f C pt) a p"
shows "matches γ (replace_primitive_matchexpr disc_sel replace_f m) a p ⟷ matches γ m a p"
proof -
obtain spts rst where pext: "primitive_extractor disc_sel m = (spts, rst)"
by(cases "primitive_extractor disc_sel m") simp
obtain disc sel where disc_sel: "disc_sel = (disc, sel)" by(cases disc_sel) simp
with wf_disc_sel have wf_disc_sel': "wf_disc_sel (disc, sel) C" by simp
from disc_sel pext have pext': "primitive_extractor (disc, sel) m = (spts, rst)" by simp
have "matches γ (andfold_MatchExp (map replace_f spts)) a p ∧ matches γ rst a p ⟷
matches γ m a p"
apply(subst primitive_extractor_correct(1)[OF n wf_disc_sel' pext', symmetric])
apply(simp add: andfold_MatchExp_matches)
apply(simp add: replace_f)
using alist_and_negation_type_to_match_expr_f_matches by fast
thus ?thesis by(simp add: replace_primitive_matchexpr_def pext bunch_of_lemmata_about_matches)
qed
lemma replace_primitive_matchexpr_replaces_disc:
assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc, sel) C"
and replace_f: "∀a. ¬ has_disc disc (replace_f a)"
shows "¬ has_disc disc (replace_primitive_matchexpr (disc, sel) replace_f m)"
apply(simp add: replace_primitive_matchexpr_def)
apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
apply(simp)
apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
apply simp
apply(frule primitive_extractor_correct(7)[OF n wf_disc_sel])
apply simp
apply(case_tac "¬ has_disc disc m")
apply(simp)
apply(simp)
apply(frule(1) primitive_extractor_correct(9)[OF n wf_disc_sel])
apply(simp)
apply(rule MatchExpr_Fold.andfold_MatchExp_not_discI)
using replace_f by simp
lemma replace_primitive_matchexpr_preserves_not_has_disc:
assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
and nodisc: "¬ has_disc disc2 m"
and replace_f: "has_disc disc m ⟹ ∀pts. ¬ has_disc disc2 (replace_f pts)"
shows "¬ has_disc disc2 (replace_primitive_matchexpr (disc,sel) replace_f m)"
apply(simp add: replace_primitive_matchexpr_def)
apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
apply(simp)
apply(frule primitive_extractor_correct(4)[OF n wf_disc_sel])
apply(case_tac "¬ has_disc disc m")
subgoal
apply(frule primitive_extractor_correct(7)[OF n wf_disc_sel])
using nodisc by blast
apply(simp)
apply(intro conjI impI)
using nodisc apply(simp; fail)
apply(rule andfold_MatchExp_not_discI)
apply(simp add: replace_f; fail)
using nodisc by blast
lemma normalize_replace_primitive_matchexpr_preserves_normalized_n_primitive:
assumes n: "normalized_nnf_match m"
and wf_disc_sel: "wf_disc_sel (disc, sel) C"
and replace_f:
"⋀a m'. m' ∈ set (normalize_match (replace_f a)) ⟹ normalized_n_primitive (disc2, sel2) f m'"
and nprim: "normalized_n_primitive (disc2, sel2) f m"
and m': "m' ∈ set (normalize_match (replace_primitive_matchexpr (disc,sel) replace_f m))"
shows "normalized_n_primitive (disc2, sel2) f m'"
proof -
have x: "x ∈ set (normalize_match (andfold_MatchExp (map replace_f as))) ⟹
normalized_n_primitive (disc2, sel2) f x" for x as
apply(rule normalize_andfold_MatchExp_normalized_n_primitive )
apply(simp_all)
using replace_f by blast
from m' show ?thesis
apply(simp add: replace_primitive_matchexpr_def)
apply(case_tac "primitive_extractor (disc, sel) m", rename_tac as rst)
apply(simp split: if_split_asm)
using normalize_match_preserves_normalized_n_primitive nprim apply blast
apply(frule_tac P=f in primitive_extractor_correct(5)[OF n wf_disc_sel])
apply(clarify)
apply(simp)
apply(intro conjI)
prefer 2
using normalize_match_preserves_normalized_n_primitive nprim apply blast
by(simp add: x)
qed
lemma normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc:
assumes n: "normalized_nnf_match m"
and wf_disc_sel: "wf_disc_sel (disc, sel) C"
and nodisc: "¬ has_disc disc2 m"
and replace_f: "⋀a. ¬ has_disc disc2 (replace_f a)"
shows "m'∈ set (normalize_match (replace_primitive_matchexpr (disc,sel) replace_f m))
⟹ ¬ has_disc disc2 m'"
apply(simp add: replace_primitive_matchexpr_def)
apply(case_tac "primitive_extractor (disc, sel) m", rename_tac as rst)
apply(simp split: if_split_asm)
using nodisc normalize_match_preserves_nodisc apply blast
apply(frule primitive_extractor_correct(4)[OF n wf_disc_sel])
apply(elim bexE, rename_tac x)
apply(erule Set.imageE, rename_tac xright)
apply(simp)
apply(intro conjI)
apply(rule normalize_match_preserves_nodisc, simp_all)
apply(rule andfold_MatchExp_not_discI, simp)
using replace_f apply blast
apply(rule normalize_match_preserves_nodisc)
apply(insert nodisc)
by(simp_all)
lemma normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc_negated:
assumes n: "normalized_nnf_match m"
and wf_disc_sel: "wf_disc_sel (disc, sel) C"
and nodisc: "¬ has_disc_negated disc2 neg m"
and replace_f: "⋀a. ¬ has_disc_negated disc2 neg (replace_f a)"
shows "m'∈ set (normalize_match (replace_primitive_matchexpr (disc,sel) replace_f m))
⟹ ¬ has_disc_negated disc2 neg m'"
apply(simp add: replace_primitive_matchexpr_def)
apply(case_tac "primitive_extractor (disc, sel) m", rename_tac as rst)
apply(simp split: if_split_asm)
using nodisc not_has_disc_normalize_match apply blast
apply(frule primitive_extractor_correct(6)[OF n wf_disc_sel, where neg=neg])
apply(elim bexE, rename_tac x)
apply(erule Set.imageE, rename_tac xright)
apply(simp)
apply(intro conjI)
apply(rule not_has_disc_normalize_match, simp_all)
apply(rule andfold_MatchExp_not_disc_negatedI, simp)
using replace_f apply blast
apply(rule not_has_disc_normalize_match)
apply(insert nodisc)
by(simp_all)
corollary normalize_replace_primitive_matchexpr:
assumes n: "normalized_nnf_match m"
and replace_f:
"⋀m. normalized_nnf_match m ⟹
matches γ (replace_primitive_matchexpr disc_sel replace_f m) a p ⟷ matches γ m a p"
shows
"match_list γ (normalize_match (replace_primitive_matchexpr disc_sel replace_f m)) a p ⟷
matches γ m a p"
by(simp add: matches_to_match_list_normalize[symmetric] replace_f n)
fun rewrite_MultiportPorts_one
:: "ipt_l4_ports negation_type⇒ 'i::len common_primitive match_expr" where
"rewrite_MultiportPorts_one (Pos pts) =
MatchOr (Match (Src_Ports pts)) (Match (Dst_Ports pts))" |
"rewrite_MultiportPorts_one (Neg pts) =
MatchAnd (MatchNot (Match (Src_Ports pts))) (MatchNot (Match (Dst_Ports pts)))"
lemma rewrite_MultiportPorts_one:
assumes generic: "primitive_matcher_generic β" and n: "normalized_nnf_match m"
shows
"matches (β, α) (replace_primitive_matchexpr (is_MultiportPorts, multiportports_sel) rewrite_MultiportPorts_one m) a p ⟷
matches (β, α) m a p"
apply(rule replace_primitive_matchexpr[OF n wf_disc_sel_common_primitive(11)])
apply(rule allI, rename_tac pt)
apply(case_tac pt)
apply(simp add: primitive_matcher_generic.MultiportPorts_single_rewrite_MatchOr[OF generic]; fail)
apply(simp add: primitive_matcher_generic.MultiportPorts_single_not_rewrite_MatchAnd[OF generic]; fail)
done
lemma "∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Dst_Ports a) ⟹
normalized_n_primitive (disc, sel) f m ⟹
∀m' ∈ set (normalize_match (rewrite_MultiportPorts_one a)).
normalized_n_primitive (disc, sel) f m'"
apply(cases a)
by(simp_all add: MatchOr_def)
lemma rewrite_MultiportPorts_one_nodisc:
"∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Dst_Ports a) ⟹
¬ has_disc disc (rewrite_MultiportPorts_one a)"
"∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Dst_Ports a) ⟹
¬ has_disc_negated disc neg (rewrite_MultiportPorts_one a)"
by(cases a, simp_all add: MatchOr_def)+
definition rewrite_MultiportPorts
:: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr list" where
"rewrite_MultiportPorts m ≡ normalize_match
(replace_primitive_matchexpr (is_MultiportPorts, multiportports_sel) rewrite_MultiportPorts_one m)"
lemma rewrite_MultiportPorts:
assumes generic: "primitive_matcher_generic β"
and n: "normalized_nnf_match m"
shows
"match_list (β, α) (rewrite_MultiportPorts m) a p ⟷ matches (β, α) m a p"
unfolding rewrite_MultiportPorts_def
apply(intro normalize_replace_primitive_matchexpr[OF n])
by(simp add: rewrite_MultiportPorts_one[OF generic])
lemma rewrite_MultiportPorts_normalized_nnf_match:
"m' ∈ set (rewrite_MultiportPorts m) ⟹ normalized_nnf_match m'"
apply(simp add: rewrite_MultiportPorts_def)
using normalized_nnf_match_normalize_match by blast
text‹It does nothing of there is not even the primitive in it›
lemma rewrite_MultiportPorts_unchanged_if_not_has_disc:
assumes n: "normalized_nnf_match m"
and noDisc: "¬ has_disc is_MultiportPorts m"
shows "rewrite_MultiportPorts m = [m]"
apply(simp add: rewrite_MultiportPorts_def)
apply(subst replace_primitive_matchexpr_unchanged_if_not_has_disc[OF n
wf_disc_sel_common_primitive(11) noDisc])
using n by(fact normalize_match_already_normalized)
lemma rewrite_MultiportPorts_preserves_normalized_n_primitive:
assumes n: "normalized_nnf_match m"
and disc2_noSrcPorts: "∀a. ¬ disc2 (Src_Ports a)"
and disc2_noDstPorts: "∀a. ¬ disc2 (Dst_Ports a)"
shows "m' ∈ set (rewrite_MultiportPorts m) ⟹
normalized_n_primitive (disc2, sel2) f m ⟹
normalized_n_primitive (disc2, sel2) f m'"
unfolding rewrite_MultiportPorts_def
apply(rule normalize_replace_primitive_matchexpr_preserves_normalized_n_primitive[OF
n wf_disc_sel_common_primitive(11)])
apply simp_all
apply(rename_tac a a')
apply(case_tac a)
apply(simp_all add: MatchOr_def)
using disc2_noSrcPorts disc2_noDstPorts by fastforce+
lemma rewrite_MultiportPorts_preserves_normalized_not_has_disc:
assumes n: "normalized_nnf_match m"
and nodisc: "¬ has_disc disc2 m"
and disc2_noSrcPorts: "∀a. ¬ disc2 (Src_Ports a)"
and disc2_noDstPorts: "∀a. ¬ disc2 (Dst_Ports a)"
shows "m'∈ set (rewrite_MultiportPorts m)
⟹ ¬ has_disc disc2 m'"
apply(simp add: rewrite_MultiportPorts_def)
apply(rule normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc[OF n wf_disc_sel_common_primitive(11) nodisc])
by(simp_all add: rewrite_MultiportPorts_one_nodisc disc2_noSrcPorts disc2_noDstPorts)
lemma rewrite_MultiportPorts_preserves_normalized_not_has_disc_negated:
assumes n: "normalized_nnf_match m"
and nodisc: "¬ has_disc_negated disc2 neg m"
and disc2_noSrcPorts: "∀a. ¬ disc2 (Src_Ports a)"
and disc2_noDstPorts: "∀a. ¬ disc2 (Dst_Ports a)"
shows "m'∈ set (rewrite_MultiportPorts m)
⟹ ¬ has_disc_negated disc2 neg m'"
apply(simp add: rewrite_MultiportPorts_def)
apply(rule normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc_negated[OF n wf_disc_sel_common_primitive(11) nodisc])
by(simp_all add: rewrite_MultiportPorts_one_nodisc disc2_noSrcPorts disc2_noDstPorts)
lemma rewrite_MultiportPorts_removes_MultiportsPorts:
assumes n: "normalized_nnf_match m"
shows "m' ∈ set (rewrite_MultiportPorts m) ⟹ ¬ has_disc is_MultiportPorts m'"
apply(simp add: rewrite_MultiportPorts_def)
apply(rule normalize_match_preserves_nodisc)
apply(simp_all)
apply(rule replace_primitive_matchexpr_replaces_disc[OF n wf_disc_sel_common_primitive(11)])
apply(intro allI, rename_tac a)
by(case_tac a, simp_all add: MatchOr_def)
end
Theory IpAddresses_Normalize
theory IpAddresses_Normalize
imports Common_Primitive_Lemmas
begin
subsection‹Normalizing IP Addresses›
fun normalized_src_ips :: "'i::len common_primitive match_expr ⇒ bool" where
"normalized_src_ips MatchAny = True" |
"normalized_src_ips (Match (Src (IpAddrRange _ _))) = False" |
"normalized_src_ips (Match (Src (IpAddr _))) = False" |
"normalized_src_ips (Match (Src (IpAddrNetmask _ _))) = True" |
"normalized_src_ips (Match _) = True" |
"normalized_src_ips (MatchNot (Match (Src _))) = False" |
"normalized_src_ips (MatchNot (Match _)) = True" |
"normalized_src_ips (MatchAnd m1 m2) = (normalized_src_ips m1 ∧ normalized_src_ips m2)" |
"normalized_src_ips (MatchNot (MatchAnd _ _)) = False" |
"normalized_src_ips (MatchNot (MatchNot _)) = False" |
"normalized_src_ips (MatchNot (MatchAny)) = True"
lemma normalized_src_ips_def2: "normalized_src_ips ms = normalized_n_primitive (is_Src, src_sel) normalized_cidr_ip ms"
by(induction ms rule: normalized_src_ips.induct, simp_all add: normalized_cidr_ip_def)
fun normalized_dst_ips :: "'i::len common_primitive match_expr ⇒ bool" where
"normalized_dst_ips MatchAny = True" |
"normalized_dst_ips (Match (Dst (IpAddrRange _ _))) = False" |
"normalized_dst_ips (Match (Dst (IpAddr _))) = False" |
"normalized_dst_ips (Match (Dst (IpAddrNetmask _ _))) = True" |
"normalized_dst_ips (Match _) = True" |
"normalized_dst_ips (MatchNot (Match (Dst _))) = False" |
"normalized_dst_ips (MatchNot (Match _)) = True" |
"normalized_dst_ips (MatchAnd m1 m2) = (normalized_dst_ips m1 ∧ normalized_dst_ips m2)" |
"normalized_dst_ips (MatchNot (MatchAnd _ _)) = False" |
"normalized_dst_ips (MatchNot (MatchNot _)) = False" |
"normalized_dst_ips (MatchNot MatchAny) = True"
lemma normalized_dst_ips_def2: "normalized_dst_ips ms = normalized_n_primitive (is_Dst, dst_sel) normalized_cidr_ip ms"
by(induction ms rule: normalized_dst_ips.induct, simp_all add: normalized_cidr_ip_def)
value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
(MatchAnd (MatchNot (Match ((Src_Ports (L4Ports TCP [(1,2)])):: 32 common_primitive))) (Match (Src_Ports (L4Ports TCP [(1,2)]))))"
value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
(MatchAnd (MatchNot (Match (Src (IpAddrNetmask (10::ipv4addr) 2)))) (Match (Src_Ports (L4Ports TCP [(1,2)]))))"
value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
(MatchAnd (Match (Src (IpAddrNetmask (10::ipv4addr) 2))) (MatchAnd (Match (Src (IpAddrNetmask 10 8))) (Match (Src_Ports (L4Ports TCP [(1,2)])))))"
value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
(MatchAnd (Match (Src (IpAddrNetmask (10::ipv4addr) 2))) (MatchAnd (Match (Src (IpAddrNetmask 192 8))) (Match (Src_Ports (L4Ports TCP [(1,2)])))))"
definition normalize_src_ips :: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr list" where
"normalize_src_ips = normalize_primitive_extract (common_primitive.is_Src, src_sel)
common_primitive.Src ipt_iprange_compress"
lemma ipt_iprange_compress_src_matching: "match_list (common_matcher, α) (map (Match ∘ Src) (ipt_iprange_compress ml)) a p ⟷
matches (common_matcher, α) (alist_and (NegPos_map Src ml)) a p"
proof -
have "matches (common_matcher, α) (alist_and (NegPos_map common_primitive.Src ml)) a p ⟷
(∀m ∈ set (getPos ml). matches (common_matcher, α) (Match (Src m)) a p) ∧
(∀m ∈ set (getNeg ml). matches (common_matcher, α) (MatchNot (Match (Src m))) a p)"
by(induction ml rule: alist_and.induct) (auto simp add: bunch_of_lemmata_about_matches)
also have "… ⟷ p_src p ∈ (⋂ ip ∈ set (getPos ml). ipt_iprange_to_set ip) - (⋃ ip ∈ set (getNeg ml). ipt_iprange_to_set ip)"
by(simp add: match_simplematcher_SrcDst match_simplematcher_SrcDst_not)
also have "… ⟷ p_src p ∈ (⋃ ip ∈ set (ipt_iprange_compress ml). ipt_iprange_to_set ip)" using ipt_iprange_compress
by blast
also have "… ⟷ (∃ip ∈ set (ipt_iprange_compress ml). matches (common_matcher, α) (Match (Src ip)) a p)"
by(simp add: match_simplematcher_SrcDst)
finally show ?thesis using match_list_matches by fastforce
qed
lemma normalize_src_ips: "normalized_nnf_match m ⟹
match_list (common_matcher, α) (normalize_src_ips m) a p = matches (common_matcher, α) m a p"
unfolding normalize_src_ips_def
using normalize_primitive_extract[OF _ wf_disc_sel_common_primitive(3), where f=ipt_iprange_compress and γ="(common_matcher, α)"]
ipt_iprange_compress_src_matching by blast
lemma normalize_src_ips_normalized_n_primitive: "normalized_nnf_match m ⟹
∀m' ∈ set (normalize_src_ips m). normalized_src_ips m'"
unfolding normalize_src_ips_def
unfolding normalized_src_ips_def2
apply(rule normalize_primitive_extract_normalizes_n_primitive[OF _ wf_disc_sel_common_primitive(3)])
by(simp_all add: ipt_iprange_compress_normalized_IpAddrNetmask)
definition normalize_dst_ips :: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr list" where
"normalize_dst_ips = normalize_primitive_extract (common_primitive.is_Dst, dst_sel)
common_primitive.Dst ipt_iprange_compress"
lemma ipt_iprange_compress_dst_matching: "match_list (common_matcher, α) (map (Match ∘ Dst) (ipt_iprange_compress ml)) a p ⟷
matches (common_matcher, α) (alist_and (NegPos_map Dst ml)) a p"
proof -
have "matches (common_matcher, α) (alist_and (NegPos_map common_primitive.Dst ml)) a p ⟷
(∀m ∈ set (getPos ml). matches (common_matcher, α) (Match (Dst m)) a p) ∧
(∀m ∈ set (getNeg ml). matches (common_matcher, α) (MatchNot (Match (Dst m))) a p)"
by(induction ml rule: alist_and.induct) (auto simp add: bunch_of_lemmata_about_matches)
also have "… ⟷ p_dst p ∈ (⋂ ip ∈ set (getPos ml). ipt_iprange_to_set ip) - (⋃ ip ∈ set (getNeg ml). ipt_iprange_to_set ip)"
by(simp add: match_simplematcher_SrcDst match_simplematcher_SrcDst_not)
also have "… ⟷ p_dst p ∈ (⋃ ip ∈ set (ipt_iprange_compress ml). ipt_iprange_to_set ip)" using ipt_iprange_compress by blast
also have "… ⟷ (∃ip ∈ set (ipt_iprange_compress ml). matches (common_matcher, α) (Match (Dst ip)) a p)"
by(simp add: match_simplematcher_SrcDst)
finally show ?thesis using match_list_matches by fastforce
qed
lemma normalize_dst_ips: "normalized_nnf_match m ⟹
match_list (common_matcher, α) (normalize_dst_ips m) a p = matches (common_matcher, α) m a p"
unfolding normalize_dst_ips_def
using normalize_primitive_extract[OF _ wf_disc_sel_common_primitive(4), where f=ipt_iprange_compress and γ="(common_matcher, α)"]
ipt_iprange_compress_dst_matching by blast
text‹Normalizing the dst ips preserves the normalized src ips›
lemma "normalized_nnf_match m ⟹ normalized_src_ips m ⟹ ∀mn∈set (normalize_dst_ips m). normalized_src_ips mn"
unfolding normalize_dst_ips_def normalized_src_ips_def2
by(rule normalize_primitive_extract_preserves_unrelated_normalized_n_primitive)(simp_all add: wf_disc_sel_common_primitive)
lemma normalize_dst_ips_normalized_n_primitive: "normalized_nnf_match m ⟹
∀m' ∈ set (normalize_dst_ips m). normalized_dst_ips m'"
unfolding normalize_dst_ips_def normalized_dst_ips_def2
by(rule normalize_primitive_extract_normalizes_n_primitive[OF _ wf_disc_sel_common_primitive(4)]) (simp_all add: ipt_iprange_compress_normalized_IpAddrNetmask)
end
Theory Interfaces_Normalize
theory Interfaces_Normalize
imports Common_Primitive_Lemmas
begin
subsection‹Optimizing interfaces in match expressions›
definition compress_interfaces :: "iface negation_type list ⇒ (iface list × iface list) option" where
"compress_interfaces ifces ≡ case (compress_pos_interfaces (getPos ifces))
of None ⇒ None
| Some i ⇒ if
∃negated_ifce ∈ set (getNeg ifces). iface_subset i negated_ifce
then
None
else if
¬ iface_is_wildcard i
then
Some ([i], [])
else
Some ((if i = ifaceAny then [] else [i]), getNeg ifces)"
context
begin
private lemma compress_interfaces_None:
assumes generic: "primitive_matcher_generic β"
shows
"compress_interfaces ifces = None ⟹ ¬ matches (β, α) (alist_and (NegPos_map IIface ifces)) a p"
"compress_interfaces ifces = None ⟹ ¬ matches (β, α) (alist_and (NegPos_map OIface ifces)) a p"
apply(simp_all add: compress_interfaces_def)
apply(simp_all add: nt_match_list_matches[symmetric] nt_match_list_simp)
apply(simp_all add: NegPos_map_simps primitive_matcher_generic.Iface_single[OF generic]
primitive_matcher_generic.Iface_single_not[OF generic])
apply(case_tac [!] "compress_pos_interfaces (getPos ifces)")
apply(simp_all)
apply(drule_tac p_i="p_iiface p" in compress_pos_interfaces_None)
apply(simp; fail)
apply(drule_tac p_i="p_iiface p" in compress_pos_interfaces_Some)
apply(simp split:if_split_asm)
using iface_subset apply blast
apply(drule_tac p_i="p_oiface p" in compress_pos_interfaces_None)
apply(simp; fail)
apply(drule_tac p_i="p_oiface p" in compress_pos_interfaces_Some)
apply(simp split:if_split_asm)
using iface_subset by blast
private lemma compress_interfaces_Some:
assumes generic: "primitive_matcher_generic β"
shows
"compress_interfaces ifces = Some (i_pos, i_neg) ⟹
matches (β, α) (alist_and (NegPos_map IIface ((map Pos i_pos)@(map Neg i_neg)))) a p ⟷
matches (β, α) (alist_and (NegPos_map IIface ifces)) a p"
"compress_interfaces ifces = Some (i_pos, i_neg) ⟹
matches (β, α) (alist_and (NegPos_map OIface ((map Pos i_pos)@(map Neg i_neg)))) a p ⟷
matches (β, α) (alist_and (NegPos_map OIface ifces)) a p"
apply(simp_all add: compress_interfaces_def)
apply(simp_all add: bunch_of_lemmata_about_matches(1) alist_and_append NegPos_map_append)
apply(simp_all add: nt_match_list_matches[symmetric] nt_match_list_simp)
apply(simp_all add: NegPos_map_simps primitive_matcher_generic.Iface_single[OF generic]
primitive_matcher_generic.Iface_single_not[OF generic])
apply(case_tac [!] "compress_pos_interfaces (getPos ifces)")
apply(simp_all)
apply(drule_tac p_i="p_iiface p" in compress_pos_interfaces_Some)
apply(simp split:if_split_asm)
using iface_is_wildcard_def iface_subset match_iface_case_nowildcard apply fastforce
using match_ifaceAny apply blast
apply force
apply(drule_tac p_i="p_oiface p" in compress_pos_interfaces_Some)
apply(simp split:if_split_asm)
using iface_is_wildcard_def iface_subset match_iface_case_nowildcard apply fastforce
using match_ifaceAny apply blast
by force
definition compress_normalize_input_interfaces :: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr option" where
"compress_normalize_input_interfaces m ≡ compress_normalize_primitive (is_Iiface, iiface_sel) IIface compress_interfaces m"
lemma compress_normalize_input_interfaces_Some:
assumes generic: "primitive_matcher_generic β"
and "normalized_nnf_match m" and "compress_normalize_input_interfaces m = Some m'"
shows "matches (β, α) m' a p ⟷ matches (β, α) m a p"
apply(rule compress_normalize_primitive_Some[OF assms(2) wf_disc_sel_common_primitive(5)])
using assms(3) apply(simp add: compress_normalize_input_interfaces_def; fail)
using compress_interfaces_Some[OF generic] by simp
lemma compress_normalize_input_interfaces_None:
assumes generic: "primitive_matcher_generic β"
and "normalized_nnf_match m" and "compress_normalize_input_interfaces m = None"
shows "¬ matches (β, α) m a p"
apply(rule compress_normalize_primitive_None[OF assms(2) wf_disc_sel_common_primitive(5)])
using assms(3) apply(simp add: compress_normalize_input_interfaces_def; fail)
using compress_interfaces_None[OF generic] by simp
lemma compress_normalize_input_interfaces_nnf: "normalized_nnf_match m ⟹ compress_normalize_input_interfaces m = Some m' ⟹
normalized_nnf_match m'"
unfolding compress_normalize_input_interfaces_def
using compress_normalize_primitive_nnf[OF wf_disc_sel_common_primitive(5)] by blast
lemma compress_normalize_input_interfaces_not_introduces_Iiface:
"¬ has_disc is_Iiface m ⟹ normalized_nnf_match m ⟹ compress_normalize_input_interfaces m = Some m' ⟹
¬ has_disc is_Iiface m'"
apply(simp add: compress_normalize_input_interfaces_def)
apply(drule compress_normalize_primitive_not_introduces_C[where m=m and C'=IIface])
apply(simp_all add: wf_disc_sel_common_primitive(5))
by(simp add: compress_interfaces_def iface_is_wildcard_ifaceAny)
lemma compress_normalize_input_interfaces_not_introduces_Iiface_negated:
assumes notdisc: "¬ has_disc_negated is_Iiface False m"
and nm: "normalized_nnf_match m"
and some: "compress_normalize_input_interfaces m = Some m'"
shows "¬ has_disc_negated is_Iiface False m'"
apply(rule compress_normalize_primitive_not_introduces_C_negated[OF notdisc wf_disc_sel_common_primitive(5) nm])
using some apply(simp add: compress_normalize_input_interfaces_def)
by(simp add: compress_interfaces_def split: option.split_asm if_split_asm)
lemma compress_normalize_input_interfaces_hasdisc:
"¬ has_disc disc m ⟹ (∀a. ¬ disc (IIface a)) ⟹ normalized_nnf_match m ⟹ compress_normalize_input_interfaces m = Some m' ⟹
normalized_nnf_match m' ∧ ¬ has_disc disc m'"
unfolding compress_normalize_input_interfaces_def
using compress_normalize_primitive_hasdisc[OF _ wf_disc_sel_common_primitive(5)] by blast
lemma compress_normalize_input_interfaces_hasdisc_negated:
"¬ has_disc_negated disc neg m ⟹ (∀a. ¬ disc (IIface a)) ⟹ normalized_nnf_match m ⟹ compress_normalize_input_interfaces m = Some m' ⟹
normalized_nnf_match m' ∧ ¬ has_disc_negated disc neg m'"
unfolding compress_normalize_input_interfaces_def
using compress_normalize_primitive_hasdisc_negated[OF _ wf_disc_sel_common_primitive(5)] by blast
lemma compress_normalize_input_interfaces_preserves_normalized_n_primitive:
"normalized_n_primitive (disc, sel) P m ⟹ (∀a. ¬ disc (IIface a)) ⟹ normalized_nnf_match m ⟹ compress_normalize_input_interfaces m = Some m' ⟹
normalized_nnf_match m' ∧ normalized_n_primitive (disc, sel) P m'"
unfolding compress_normalize_input_interfaces_def
using compress_normalize_primitve_preserves_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(5)] by blast
value[code] "compress_normalize_input_interfaces
(MatchAnd (MatchAnd (MatchAnd (Match ((IIface (Iface ''eth+'')::32 common_primitive))) (MatchNot (Match (IIface (Iface ''eth4''))))) (Match (IIface (Iface ''eth1''))))
(Match (Prot (Proto TCP))))"
value[code] "compress_normalize_input_interfaces (MatchAny:: 32 common_primitive match_expr)"
definition compress_normalize_output_interfaces :: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr option" where
"compress_normalize_output_interfaces m ≡ compress_normalize_primitive (is_Oiface, oiface_sel) OIface compress_interfaces m"
lemma compress_normalize_output_interfaces_Some:
assumes generic: "primitive_matcher_generic β"
and "normalized_nnf_match m" and "compress_normalize_output_interfaces m = Some m'"
shows "matches (β, α) m' a p ⟷ matches (β, α) m a p"
apply(rule compress_normalize_primitive_Some[OF assms(2) wf_disc_sel_common_primitive(6)])
using assms(3) apply(simp add: compress_normalize_output_interfaces_def; fail)
using compress_interfaces_Some[OF generic] by simp
lemma compress_normalize_output_interfaces_None:
assumes generic: "primitive_matcher_generic β"
and "normalized_nnf_match m" and "compress_normalize_output_interfaces m = None"
shows "¬ matches (β, α) m a p"
apply(rule compress_normalize_primitive_None[OF assms(2) wf_disc_sel_common_primitive(6)])
using assms(3) apply(simp add: compress_normalize_output_interfaces_def; fail)
using compress_interfaces_None[OF generic] by simp
lemma compress_normalize_output_interfaces_nnf: "normalized_nnf_match m ⟹ compress_normalize_output_interfaces m = Some m' ⟹
normalized_nnf_match m'"
unfolding compress_normalize_output_interfaces_def
using compress_normalize_primitive_nnf[OF wf_disc_sel_common_primitive(6)] by blast
lemma compress_normalize_output_interfaces_not_introduces_Oiface:
"¬ has_disc is_Oiface m ⟹ normalized_nnf_match m ⟹ compress_normalize_output_interfaces m = Some m' ⟹
¬ has_disc is_Oiface m'"
apply(simp add: compress_normalize_output_interfaces_def)
apply(drule compress_normalize_primitive_not_introduces_C[where m=m and C'=OIface])
apply(simp_all add: wf_disc_sel_common_primitive(6))
by(simp add: compress_interfaces_def iface_is_wildcard_ifaceAny)
lemma compress_normalize_output_interfaces_not_introduces_Oiface_negated:
assumes notdisc: "¬ has_disc_negated is_Oiface False m"
and nm: "normalized_nnf_match m"
and some: "compress_normalize_output_interfaces m = Some m'"
shows "¬ has_disc_negated is_Oiface False m'"
apply(rule compress_normalize_primitive_not_introduces_C_negated[OF notdisc wf_disc_sel_common_primitive(6) nm])
using some apply(simp add: compress_normalize_output_interfaces_def)
by(simp add: compress_interfaces_def split: option.split_asm if_split_asm)
lemma compress_normalize_output_interfaces_hasdisc:
"¬ has_disc disc m ⟹ (∀a. ¬ disc (OIface a)) ⟹ normalized_nnf_match m ⟹ compress_normalize_output_interfaces m = Some m' ⟹
normalized_nnf_match m' ∧ ¬ has_disc disc m'"
unfolding compress_normalize_output_interfaces_def
using compress_normalize_primitive_hasdisc[OF _ wf_disc_sel_common_primitive(6)] by blast
lemma compress_normalize_output_interfaces_hasdisc_negated:
"¬ has_disc_negated disc neg m ⟹ (∀a. ¬ disc (OIface a)) ⟹ normalized_nnf_match m ⟹ compress_normalize_output_interfaces m = Some m' ⟹
normalized_nnf_match m' ∧ ¬ has_disc_negated disc neg m'"
unfolding compress_normalize_output_interfaces_def
using compress_normalize_primitive_hasdisc_negated[OF _ wf_disc_sel_common_primitive(6)] by blast
lemma compress_normalize_output_interfaces_preserves_normalized_n_primitive:
"normalized_n_primitive (disc, sel) P m ⟹ (∀a. ¬ disc (OIface a)) ⟹ normalized_nnf_match m ⟹ compress_normalize_output_interfaces m = Some m' ⟹
normalized_nnf_match m' ∧ normalized_n_primitive (disc, sel) P m'"
unfolding compress_normalize_output_interfaces_def
using compress_normalize_primitve_preserves_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(6)] by blast
end
end
Theory Word_Upto
section‹Word Upto›
theory Word_Upto
imports Main
IP_Addresses.Hs_Compat
Word_Lib.Word_Lemmas
begin
text‹Enumerate a range of machine words.›
text‹enumerate from the back (inefficient)›
function word_upto :: "'a word ⇒ 'a word ⇒ ('a::len) word list" where
"word_upto a b = (if a = b then [a] else word_upto a (b - 1) @ [b])"
by pat_completeness auto
termination word_upto
apply(relation "measure (unat ∘ uncurry (-) ∘ prod.swap)")
apply(rule wf_measure; fail)
apply(simp)
apply(subgoal_tac "unat (b - a - 1) < unat (b - a)")
apply(simp add: diff_right_commute; fail)
apply(rule measure_unat)
apply auto
done
declare word_upto.simps[simp del]
text‹enumerate from the front (more inefficient)›
function word_upto' :: "'a word ⇒ 'a word ⇒ ('a::len) word list" where
"word_upto' a b = (if a = b then [a] else a # word_upto' (a + 1) b)"
by pat_completeness auto
termination word_upto'
apply(relation "measure (λ (a, b). unat (b - a))")
apply(rule wf_measure; fail)
apply(simp)
apply(subgoal_tac "unat (b - a - 1) < unat (b - a)")
apply (simp add: diff_diff_add; fail)
apply(rule measure_unat)
apply auto
done
declare word_upto'.simps[simp del]
lemma word_upto_cons_front[code]:
"word_upto a b = word_upto' a b"
proof(induction a b rule:word_upto'.induct)
case (1 a b)
have hlp1: "a ≠ b ⟹ a # word_upto (a + 1) b = word_upto a b"
apply(induction a b rule:word_upto.induct)
apply simp
apply(subst(1) word_upto.simps)
apply(simp)
apply safe
apply(subst(1) word_upto.simps)
apply (simp)
apply(subst(1) word_upto.simps)
apply (simp; fail)
apply(case_tac "a ≠ b - 1")
apply(simp)
apply (metis Cons_eq_appendI word_upto.simps)
apply(simp)
done
from 1[symmetric] show ?case
apply(cases "a = b")
subgoal
apply(subst word_upto.simps)
apply(subst word_upto'.simps)
by(simp)
apply(subst word_upto'.simps)
by(simp add: hlp1)
qed
lemma word_upto_set_eq: "a ≤ b ⟹ x ∈ set (word_upto a b) ⟷ a ≤ x ∧ x ≤ b"
proof
show "a ≤ b ⟹ x ∈ set (word_upto a b) ⟹ a ≤ x ∧ x ≤ b"
apply(induction a b rule: word_upto.induct)
apply(case_tac "a = b")
apply(subst(asm) word_upto.simps)
apply(simp; fail)
apply(subst(asm) word_upto.simps)
apply(simp)
apply(erule disjE)
apply(simp; fail)
proof(goal_cases)
case (1 a b)
from 1(2-3) have "b ≠ 0" by force
from 1(2,3) have "a ≤ b - 1"
by (simp add: word_le_minus_one_leq)
from 1(1)[OF this 1(4)] show ?case by (metis dual_order.trans 1(2,3) less_imp_le measure_unat word_le_0_iff word_le_nat_alt)
qed
next
show "a ≤ x ∧ x ≤ b ⟹ x ∈ set (word_upto a b)"
apply(induction a b rule: word_upto.induct)
apply(case_tac "a = b")
apply(subst word_upto.simps)
apply(simp; force)
apply(subst word_upto.simps)
apply(simp)
apply(case_tac "x = b")
apply(simp;fail)
proof(goal_cases)
case (1 a b)
from 1(2-4) have "b ≠ 0" by force
from 1(2,4) have "x ≤ b - 1"
using le_step_down_word by auto
from 1(1) this show ?case by simp
qed
qed
lemma word_upto_distinct_hlp: "a ≤ b ⟹ a ≠ b ⟹ b ∉ set (word_upto a (b - 1))"
apply(rule ccontr, unfold not_not)
apply(subgoal_tac "a ≤ b - 1")
apply(drule iffD1[OF word_upto_set_eq[of a "b -1" b]])
apply(simp add: word_upto.simps)
apply(subgoal_tac "b ≠ 0")
apply(meson leD measure_unat word_le_nat_alt)
apply(blast intro: iffD1[OF word_le_0_iff])
using le_step_down_word apply blast
done
lemma distinct_word_upto: "a ≤ b ⟹ distinct (word_upto a b)"
apply(induction a b rule: word_upto.induct)
apply(case_tac "a = b")
apply(subst word_upto.simps)
apply(simp; force)
apply(subst word_upto.simps)
apply(case_tac "a ≤ b - 1")
apply(simp)
apply(rule word_upto_distinct_hlp; simp)
apply(simp)
apply(rule ccontr)
apply (simp add: not_le antisym word_minus_one_le_leq)
done
lemma word_upto_eq_upto: "s ≤ e ⟹ e ≤ unat (max_word :: 'l word) ⟹
word_upto ((of_nat :: nat ⇒ ('l :: len) word) s) (of_nat e) = map of_nat (upt s (Suc e))"
proof(induction e)
let ?mwon = "of_nat :: nat ⇒ 'l word"
let ?mmw = "max_word :: 'l word"
case (Suc e)
show ?case
proof(cases "?mwon s = ?mwon (Suc e)")
case True
have "s = Suc e" using le_unat_uoi Suc.prems True by metis
with True show ?thesis by(subst word_upto.simps) (simp)
next
case False
hence le: "s ≤ e" using le_SucE Suc.prems by blast
have lm: "e ≤ unat ?mmw" using Suc.prems by simp
have sucm: "(of_nat :: nat ⇒ ('l :: len) word) (Suc e) - 1 = of_nat e" using Suc.prems(2) by simp
note mIH = Suc.IH[OF le lm]
show ?thesis by(subst word_upto.simps) (simp add: False[simplified] Suc.prems mIH sucm)
qed
qed(simp add: word_upto.simps)
lemma word_upto_alt: "(a :: ('l :: len) word) ≤ b ⟹
word_upto a b = map of_nat (upt (unat a) (Suc (unat b)))"
proof -
let ?mmw = "max_word :: 'l word"
assume le: "a ≤ b"
hence nle: "unat a ≤ unat b" by(unat_arith)
have lem: "unat b ≤ unat ?mmw" by (simp add: word_unat_less_le)
note word_upto_eq_upto[OF nle lem, unfolded word_unat.Rep_inverse]
thus "word_upto a b = map of_nat [unat a..<Suc (unat b)]" .
qed
lemma word_upto_upt:
"word_upto a b = (if a ≤ b then map of_nat (upt (unat a) (Suc (unat b))) else word_upto a b)"
using word_upto_alt by metis
lemma sorted_word_upto:
fixes a b :: "('l :: len) word"
assumes "a ≤ b"
shows "sorted (word_upto a b)"
proof -
define m and n where ‹m = unat a› and ‹n = Suc (unat b)›
moreover have ‹sorted (map of_nat [m..<n] :: 'l word list)›
apply (simp add: sorted_map)
apply (rule sorted_wrt_mono_rel [of _ ‹(≤)›])
apply (simp_all flip: sorted_sorted_wrt)
apply (simp add: le_unat_uoi less_Suc_eq_le n_def word_of_nat_le)
apply transfer
apply simp
apply (subst take_bit_int_eq_self)
apply (simp_all add: le_less_trans)
apply (metis le_unat_uoi of_int_of_nat_eq of_nat_mono uint_word_of_int_eq unat_eq_nat_uint unsigned_of_int)
done
ultimately have ‹sorted (map of_nat [unat a..<Suc (unat b)] :: 'l word list)›
by simp
with assms show ?thesis
by (simp only: word_upto_alt)
qed
end
Theory Protocols_Normalize
theory Protocols_Normalize
imports Common_Primitive_Lemmas
"../Common/Word_Upto"
begin
section‹Optimizing Protocols›
section‹Optimizing protocols in match expressions›
fun compress_pos_protocols :: "protocol list ⇒ protocol option" where
"compress_pos_protocols [] = Some ProtoAny" |
"compress_pos_protocols [p] = Some p" |
"compress_pos_protocols (p1#p2#ps) = (case simple_proto_conjunct p1 p2 of None ⇒ None | Some p ⇒ compress_pos_protocols (p#ps))"
lemma compress_pos_protocols_Some: "compress_pos_protocols ps = Some proto ⟹
match_proto proto p_prot ⟷ (∀ p ∈ set ps. match_proto p p_prot)"
proof(induction ps rule: compress_pos_protocols.induct)
case (3 p1 p2 pps) thus ?case
apply(cases "simple_proto_conjunct p1 p2")
apply(simp; fail)
using simple_proto_conjunct_Some by(simp)
qed(simp)+
lemma compress_pos_protocols_None: "compress_pos_protocols ps = None ⟹
¬ (∀ proto ∈ set ps. match_proto proto p_prot)"
proof(induction ps rule: compress_pos_protocols.induct)
case (3 i1 i2 iis) thus ?case
apply(cases "simple_proto_conjunct i1 i2")
apply(simp_all)
using simple_proto_conjunct_None apply blast
using simple_proto_conjunct_Some by blast
qed(simp)+
lemma "simple_proto_conjunct (Proto p1) (Proto p2) ≠ None ⟹ ∀pkt. match_proto (Proto p1) pkt ⟷ match_proto (Proto p2) pkt"
apply(subgoal_tac "p1 = p2")
apply(simp)
apply(simp split: if_split_asm)
done
lemma "simple_proto_conjunct p1 (Proto p2) ≠ None ⟹ ∀pkt. match_proto (Proto p2) pkt ⟶ match_proto p1 pkt"
apply(cases p1)
apply(simp)
apply(simp split: if_split_asm)
done
definition compress_protocols :: "protocol negation_type list ⇒ (protocol list × protocol list) option" where
"compress_protocols ps ≡ case (compress_pos_protocols (getPos ps))
of None ⇒ None
| Some proto ⇒ if ProtoAny ∈ set (getNeg ps) ∨ (∀p ∈ {0..max_word}. Proto p ∈ set (getNeg ps)) then
None
else if proto = ProtoAny then
Some ([], getNeg ps)
else if (∃p ∈ set (getNeg ps). simple_proto_conjunct proto p ≠ None) then
None
else
Some ([proto], [])"
lemma all_proto_hlp2: "ProtoAny ∈ a ∨ (∀p ∈ {0..max_word}. Proto p ∈ a) ⟷
ProtoAny ∈ a ∨ a = {p. p ≠ ProtoAny}"
proof -
have all_proto_hlp: "ProtoAny ∉ a ⟹ (∀p ∈ {0..max_word}. Proto p ∈ a) ⟷ a = {p. p ≠ ProtoAny}"
by(auto intro: protocol.exhaust)
thus ?thesis by blast
qed
lemma set_word8_word_upto: "{0..(max_word :: 8 word)} = set (word_upto 0 255)"
proof -
have ‹0xFF = (max_word :: 8 word)›
by simp
then show ?thesis
by (simp only:) (auto simp add: word_upto_set_eq)
qed
lemma "(∀p ∈ {0..max_word}. Proto p ∈ set (getNeg ps)) ⟷
((∀p ∈ set (word_upto 0 255). Proto p ∈ set (getNeg ps)))"
by(simp add: set_word8_word_upto)
lemma compress_protocols_code[code]:
"compress_protocols ps = (case (compress_pos_protocols (getPos ps))
of None ⇒ None
| Some proto ⇒ if ProtoAny ∈ set (getNeg ps) ∨ (∀p ∈ set (word_upto 0 255). Proto p ∈ set (getNeg ps)) then
None
else if proto = ProtoAny then
Some ([], getNeg ps)
else if (∃p ∈ set (getNeg ps). simple_proto_conjunct proto p ≠ None) then
None
else
Some ([proto], [])
)"
unfolding compress_protocols_def
using set_word8_word_upto by presburger
lemma "compress_protocols ps = Some (ps_pos, ps_neg) ⟹
∃ p. ((∀m∈set ps_pos. match_proto m p) ∧ (∀m∈set ps_neg. ¬ match_proto m p))"
apply(simp add: compress_protocols_def all_proto_hlp2 split: option.split_asm if_split_asm)
apply(subgoal_tac "∃p. (Proto p) ∉ set ps_neg")
apply(elim exE)
apply(rename_tac x2 p)
apply(rule_tac x=p in exI)
apply(blast elim: match_proto.elims)
apply(auto intro: protocol.exhaust)
done
definition compress_normalize_protocols_step :: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr option" where
"compress_normalize_protocols_step m ≡ compress_normalize_primitive (is_Prot, prot_sel) Prot compress_protocols m"
lemma (in primitive_matcher_generic) compress_normalize_protocols_step_Some:
assumes "normalized_nnf_match m" and "compress_normalize_protocols_step m = Some m'"
shows "matches (β, α) m' a p ⟷ matches (β, α) m a p"
proof(rule compress_normalize_primitive_Some[OF assms(1) wf_disc_sel_common_primitive(7), of compress_protocols])
show "compress_normalize_primitive (is_Prot, prot_sel) Prot compress_protocols m = Some m'"
using assms(2) by(simp add: compress_normalize_protocols_step_def)
next
fix ps ps_pos ps_neg
show "compress_protocols ps = Some (ps_pos, ps_neg) ⟹
matches (β, α) (alist_and (NegPos_map Prot ((map Pos ps_pos)@(map Neg ps_neg)))) a p ⟷
matches (β, α) (alist_and (NegPos_map Prot ps)) a p"
apply(simp add: compress_protocols_def)
apply(simp add: bunch_of_lemmata_about_matches alist_and_append NegPos_map_append)
apply(simp add: nt_match_list_matches[symmetric] nt_match_list_simp)
apply(simp add: NegPos_map_simps Prot_single Prot_single_not)
apply(case_tac "compress_pos_protocols (getPos ps)")
apply(simp_all)
apply(drule_tac p_prot="p_proto p" in compress_pos_protocols_Some)
apply(simp split:if_split_asm)
using simple_proto_conjunct_None by auto
qed
lemma (in primitive_matcher_generic) compress_normalize_protocols_step_None:
assumes "normalized_nnf_match m" and "compress_normalize_protocols_step m = None"
shows "¬ matches (β, α) m a p"
proof(rule compress_normalize_primitive_None[OF assms(1) wf_disc_sel_common_primitive(7), of "compress_protocols"])
show "compress_normalize_primitive (is_Prot, prot_sel) Prot compress_protocols m = None"
using assms(2) by(simp add: compress_normalize_protocols_step_def)
next
fix ps
have if_option_Some:
"((if P then None else Some x) = Some y) = (¬P ∧ x = y)"
for P and x::protocol and y by simp
show "compress_protocols ps = None ⟹ ¬ matches (β, α) (alist_and (NegPos_map Prot ps)) a p"
apply(simp add: compress_protocols_def)
apply(simp add: nt_match_list_matches[symmetric] nt_match_list_simp)
apply(simp add: NegPos_map_simps Prot_single Prot_single_not)
apply(cases "compress_pos_protocols (getPos ps)")
apply(simp_all)
apply(drule_tac p_prot="p_proto p" in compress_pos_protocols_None)
apply(simp; fail)
apply(drule_tac p_prot="p_proto p" in compress_pos_protocols_Some)
apply(simp split:if_split_asm)
apply fastforce
apply(elim bexE exE)
apply(simp)
apply(elim simple_proto_conjunct.elims)
apply(simp; fail)
apply(simp; fail)
using if_option_Some by metis
qed
lemma compress_normalize_protocols_step_nnf:
"normalized_nnf_match m ⟹ compress_normalize_protocols_step m = Some m' ⟹
normalized_nnf_match m'"
unfolding compress_normalize_protocols_step_def
using compress_normalize_primitive_nnf[OF wf_disc_sel_common_primitive(7)] by blast
lemma compress_normalize_protocols_step_not_introduces_Prot:
"¬ has_disc is_Prot m ⟹ normalized_nnf_match m ⟹ compress_normalize_protocols_step m = Some m' ⟹
¬ has_disc is_Prot m'"
apply(simp add: compress_normalize_protocols_step_def)
apply(drule compress_normalize_primitive_not_introduces_C[where m=m and C'=Prot])
apply(simp_all add: wf_disc_sel_common_primitive(7))
apply(simp add: compress_protocols_def split: if_splits)
done
lemma compress_normalize_protocols_step_not_introduces_Prot_negated:
assumes notdisc: "¬ has_disc_negated is_Prot False m"
and nm: "normalized_nnf_match m"
and some: "compress_normalize_protocols_step m = Some m'"
shows "¬ has_disc_negated is_Prot False m'"
apply(rule compress_normalize_primitive_not_introduces_C_negated[OF notdisc wf_disc_sel_common_primitive(7) nm])
using some apply(simp add: compress_normalize_protocols_step_def)
by(simp add: compress_protocols_def split: option.split_asm if_split_asm)
lemma compress_normalize_protocols_step_hasdisc:
"¬ has_disc disc m ⟹ (∀a. ¬ disc (Prot a)) ⟹ normalized_nnf_match m ⟹ compress_normalize_protocols_step m = Some m' ⟹
normalized_nnf_match m' ∧ ¬ has_disc disc m'"
unfolding compress_normalize_protocols_step_def
using compress_normalize_primitive_hasdisc[OF _ wf_disc_sel_common_primitive(7)] by blast
lemma compress_normalize_protocols_step_hasdisc_negated:
"¬ has_disc_negated disc neg m ⟹ (∀a. ¬ disc (Prot a)) ⟹ normalized_nnf_match m ⟹ compress_normalize_protocols_step m = Some m' ⟹
normalized_nnf_match m' ∧ ¬ has_disc_negated disc neg m'"
unfolding compress_normalize_protocols_step_def
using compress_normalize_primitive_hasdisc_negated[OF _ wf_disc_sel_common_primitive(7)] by blast
lemma compress_normalize_protocols_step_preserves_normalized_n_primitive:
"normalized_n_primitive (disc, sel) P m ⟹ (∀a. ¬ disc (Prot a)) ⟹ normalized_nnf_match m ⟹ compress_normalize_protocols_step m = Some m' ⟹
normalized_nnf_match m' ∧ normalized_n_primitive (disc, sel) P m'"
unfolding compress_normalize_protocols_step_def
using compress_normalize_primitve_preserves_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(7)] by blast
lemma "case compress_normalize_protocols_step
(MatchAnd (MatchAnd (MatchAnd (Match ((Prot (Proto TCP)):: 32 common_primitive)) (MatchNot (Match (Prot (Proto UDP))))) (Match (IIface (Iface ''eth1''))))
(Match (Prot (Proto TCP)))) of Some ps ⇒ opt_MatchAny_match_expr ps
= MatchAnd (Match (Prot (Proto 6))) (Match (IIface (Iface ''eth1'')))" by eval
value[code] "compress_normalize_protocols_step (MatchAny:: 32 common_primitive match_expr)"
subsection‹Importing the matches on @{typ primitive_protocol} from @{const L4Ports}›
definition import_protocols_from_ports
:: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr" where
"import_protocols_from_ports m ≡
(case primitive_extractor (is_Src_Ports, src_ports_sel) m of (srcpts, rst1) ⇒
case primitive_extractor (is_Dst_Ports, dst_ports_sel) rst1 of (dstpts, rst2) ⇒
MatchAnd
(MatchAnd
(MatchAnd
(andfold_MatchExp (map (Match ∘ (Prot ∘ (case_ipt_l4_ports (λproto x. Proto proto)))) (getPos srcpts)))
(andfold_MatchExp (map (Match ∘ (Prot ∘ (case_ipt_l4_ports (λproto x. Proto proto)))) (getPos dstpts)))
)
(alist_and' (NegPos_map Src_Ports srcpts @ NegPos_map Dst_Ports dstpts))
)
rst2
)"
text‹The @{const Proto} and @{const L4Ports} match make the following match impossible:›
lemma "compress_normalize_protocols_step (import_protocols_from_ports
(MatchAnd (MatchAnd (Match (Prot (Proto TCP):: 32 common_primitive))
(Match (Src_Ports (L4Ports UDP [(22,22)])))) (Match (IIface (Iface ''eth1''))))) = None"
by eval
lemma import_protocols_from_ports_erule: "normalized_nnf_match m ⟹ P m ⟹
(⋀srcpts rst1 dstpts rst2.
normalized_nnf_match m ⟹
primitive_extractor (is_Src_Ports, src_ports_sel) m = (srcpts, rst1) ⟹
primitive_extractor (is_Dst_Ports, dst_ports_sel) rst1 = (dstpts, rst2) ⟹
normalized_nnf_match rst1 ⟹
normalized_nnf_match rst2 ⟹
P (MatchAnd
(MatchAnd
(MatchAnd
(andfold_MatchExp
(map (Match ∘ (Prot ∘ (case_ipt_l4_ports (λproto x. Proto proto)))) (getPos srcpts)))
(andfold_MatchExp
(map (Match ∘ (Prot ∘ (case_ipt_l4_ports (λproto x. Proto proto)))) (getPos dstpts))))
(alist_and' (NegPos_map Src_Ports srcpts @ NegPos_map Dst_Ports dstpts)))
rst2)) ⟹
P (import_protocols_from_ports m)"
apply(simp add: import_protocols_from_ports_def)
apply(case_tac "primitive_extractor (is_Src_Ports, src_ports_sel) m", rename_tac srcpts rst1)
apply(simp)
apply(case_tac "primitive_extractor (is_Dst_Ports, dst_ports_sel) rst1", rename_tac dstpts rst2)
apply(simp)
apply(frule(1) primitive_extractor_correct(2)[OF _ wf_disc_sel_common_primitive(1)])
apply(frule(1) primitive_extractor_correct(2)[OF _ wf_disc_sel_common_primitive(2)])
apply simp
done
lemma (in primitive_matcher_generic) import_protocols_from_ports:
assumes normalized: "normalized_nnf_match m"
shows "matches (β, α) (import_protocols_from_ports m) a p ⟷ matches (β, α) m a p"
proof-
have add_protocol:
"matches (β, α)
(andfold_MatchExp (map (Match ∘ (Prot ∘ (case_ipt_l4_ports (λproto x. Proto proto)))) (getPos as))) a p ∧
matches (β, α) (alist_and (NegPos_map C as)) a p
⟷
matches (β, α) (alist_and (NegPos_map C as)) a p"
if C: "C = Src_Ports ∨ C = Dst_Ports" for C as
proof(induction as)
case Nil thus ?case by(simp)
next
case (Cons x xs)
show ?case
proof(cases x)
case Neg with Cons.IH show ?thesis
apply(simp add: bunch_of_lemmata_about_matches)
by blast
next
case (Pos portmatch)
with Cons.IH show ?thesis
apply(cases portmatch)
apply(simp add: andfold_MatchExp_matches bunch_of_lemmata_about_matches)
using Ports_single_rewrite_Prot C by blast
qed
qed
from normalized show ?thesis
apply -
apply(erule import_protocols_from_ports_erule)
apply(simp; fail)
apply(subst primitive_extractor_correct(1)[OF normalized wf_disc_sel_common_primitive(1),
where γ="(β,α)" and a=a and p=p, symmetric])
apply(simp; fail)
apply(drule(1) primitive_extractor_correct(1)[OF _ wf_disc_sel_common_primitive(2),
where γ="(β,α)" and a=a and p=p])
apply(simp add: bunch_of_lemmata_about_matches matches_alist_and_alist_and' alist_and_append)
using add_protocol by blast
qed
lemma import_protocols_from_ports_nnf:
"normalized_nnf_match m ⟹ normalized_nnf_match (import_protocols_from_ports m)"
proof -
have hlp: "∀m∈set (map (Match ∘ (Prot ∘ (case_ipt_l4_ports (λproto x. Proto proto)))) ls).
normalized_nnf_match m" for ls
apply(induction ls)
apply(simp)
apply(rename_tac l ls, case_tac l)
by(simp)
show "normalized_nnf_match m ⟹ normalized_nnf_match (import_protocols_from_ports m)"
apply(rule import_protocols_from_ports_erule)
apply(simp_all)
apply(simp add: normalized_nnf_match_alist_and')
apply(safe)
apply(rule andfold_MatchExp_normalized_nnf, simp add: hlp)+
done
qed
lemma import_protocols_from_ports_not_introduces_Prot_negated:
"normalized_nnf_match m ⟹ ¬ has_disc_negated is_Prot False m ⟹
¬ has_disc_negated is_Prot False (import_protocols_from_ports m)"
apply(erule(1) import_protocols_from_ports_erule)
apply(simp)
apply(intro conjI)
using andfold_MatchExp_not_disc_negated_mapMatch[
where C="Prot ∘ case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
using andfold_MatchExp_not_disc_negated_mapMatch[
where C="Prot ∘ case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
apply(simp add: has_disc_negated_alist_and')
using not_has_disc_negated_NegPos_map[where disc=is_Prot and C=Src_Ports, simplified]
not_has_disc_negated_NegPos_map[where disc=is_Prot and C=Dst_Ports, simplified] apply blast
apply(drule(1) primitive_extractor_correct(6)[OF _ wf_disc_sel_common_primitive(1), where neg=False])
apply(drule(1) primitive_extractor_correct(6)[OF _ wf_disc_sel_common_primitive(2), where neg=False])
by blast
lemma import_protocols_from_ports_hasdisc:
"normalized_nnf_match m ⟹ ¬ has_disc disc m ⟹ (∀a. ¬ disc (Prot a)) ⟹
normalized_nnf_match (import_protocols_from_ports m) ∧ ¬ has_disc disc (import_protocols_from_ports m)"
apply(intro conjI)
using import_protocols_from_ports_nnf apply blast
apply(erule(1) import_protocols_from_ports_erule)
apply(simp)
apply(intro conjI)
using andfold_MatchExp_not_disc_mapMatch[
where C="Prot ∘ case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
using andfold_MatchExp_not_disc_mapMatch[
where C="Prot ∘ case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
subgoal for srcpts rst1 dstpts rst2
apply(frule(2) primitive_extractor_reassemble_not_has_disc[OF wf_disc_sel_common_primitive(1)])
apply(subgoal_tac "¬ has_disc disc rst1")
prefer 2
apply(drule(1) primitive_extractor_correct(4)[OF _ wf_disc_sel_common_primitive(1)])
apply blast
apply(drule(2) primitive_extractor_reassemble_not_has_disc[OF wf_disc_sel_common_primitive(2)])
using has_disc_alist_and'_append by blast
apply(drule(1) primitive_extractor_correct(4)[OF _ wf_disc_sel_common_primitive(1)])
apply(drule(1) primitive_extractor_correct(4)[OF _ wf_disc_sel_common_primitive(2)])
apply blast
done
lemma import_protocols_from_ports_hasdisc_negated:
"¬ has_disc_negated disc False m ⟹ (∀a. ¬ disc (Prot a)) ⟹ normalized_nnf_match m ⟹
normalized_nnf_match (import_protocols_from_ports m) ∧
¬ has_disc_negated disc False (import_protocols_from_ports m)"
apply(intro conjI)
using import_protocols_from_ports_nnf apply blast
apply(erule(1) import_protocols_from_ports_erule)
apply(simp)
apply(intro conjI)
using andfold_MatchExp_not_disc_negated_mapMatch[
where C="Prot ∘ case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
using andfold_MatchExp_not_disc_negated_mapMatch[
where C="Prot ∘ case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
subgoal for srcpts rst1 dstpts rst2
apply(frule(2) primitive_extractor_reassemble_not_has_disc_negated[OF wf_disc_sel_common_primitive(1)])
apply(subgoal_tac "¬ has_disc_negated disc False rst1")
prefer 2
apply(drule(1) primitive_extractor_correct(6)[OF _ wf_disc_sel_common_primitive(1)])
apply blast
apply(drule(2) primitive_extractor_reassemble_not_has_disc_negated[OF wf_disc_sel_common_primitive(2)])
using has_disc_negated_alist_and'_append by blast
apply(drule(1) primitive_extractor_correct(6)[OF _ wf_disc_sel_common_primitive(1)])
apply(drule(1) primitive_extractor_correct(6)[OF _ wf_disc_sel_common_primitive(2)])
apply blast
done
lemma import_protocols_from_ports_preserves_normalized_n_primitive:
"normalized_n_primitive (disc, sel) f m ⟹ (∀a. ¬ disc (Prot a)) ⟹ normalized_nnf_match m ⟹
normalized_nnf_match (import_protocols_from_ports m) ∧ normalized_n_primitive (disc, sel) f (import_protocols_from_ports m)"
apply(intro conjI)
using import_protocols_from_ports_nnf apply blast
apply(erule(1) import_protocols_from_ports_erule)
apply(simp)
apply(intro conjI)
subgoal for srcpts rst1 dstpts rst2
apply(rule andfold_MatchExp_normalized_n_primitive)
using normalized_n_primitive_impossible_map by blast
subgoal for srcpts rst1 dstpts rst2
apply(rule andfold_MatchExp_normalized_n_primitive)
using normalized_n_primitive_impossible_map by blast
subgoal for srcpts rst1 dstpts rst2
apply(frule(2) primitive_extractor_reassemble_normalized_n_primitive[OF wf_disc_sel_common_primitive(1)])
apply(subgoal_tac "normalized_n_primitive (disc, sel) f rst1")
prefer 2
apply(drule(1) primitive_extractor_correct(5)[OF _ wf_disc_sel_common_primitive(1)])
apply blast
apply(drule(2) primitive_extractor_reassemble_normalized_n_primitive[OF wf_disc_sel_common_primitive(2)])
using normalized_n_primitive_alist_and'_append by blast
apply(drule(1) primitive_extractor_correct(5)[OF _ wf_disc_sel_common_primitive(1)])
apply(drule(1) primitive_extractor_correct(5)[OF _ wf_disc_sel_common_primitive(2)])
apply blast
done
subsection‹Putting things together›
definition compress_normalize_protocols
:: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr option" where
"compress_normalize_protocols m ≡ compress_normalize_protocols_step (import_protocols_from_ports m)"
lemma (in primitive_matcher_generic) compress_normalize_protocols_Some:
assumes "normalized_nnf_match m" and "compress_normalize_protocols m = Some m'"
shows "matches (β, α) m' a p ⟷ matches (β, α) m a p"
using assms apply(simp add: compress_normalize_protocols_def)
by (metis import_protocols_from_ports import_protocols_from_ports_nnf
compress_normalize_protocols_step_Some)
lemma (in primitive_matcher_generic) compress_normalize_protocols_None:
assumes "normalized_nnf_match m" and "compress_normalize_protocols m = None"
shows "¬ matches (β, α) m a p"
using assms apply(simp add: compress_normalize_protocols_def)
by (metis import_protocols_from_ports import_protocols_from_ports_nnf
compress_normalize_protocols_step_None)
lemma compress_normalize_protocols_nnf:
"normalized_nnf_match m ⟹ compress_normalize_protocols m = Some m' ⟹
normalized_nnf_match m'"
apply(simp add: compress_normalize_protocols_def)
by (metis import_protocols_from_ports_nnf compress_normalize_protocols_step_nnf)
lemma compress_normalize_protocols_not_introduces_Prot_negated:
assumes notdisc: "¬ has_disc_negated is_Prot False m"
and nm: "normalized_nnf_match m"
and some: "compress_normalize_protocols m = Some m'"
shows "¬ has_disc_negated is_Prot False m'"
using assms apply(simp add: compress_normalize_protocols_def)
using import_protocols_from_ports_nnf
import_protocols_from_ports_not_introduces_Prot_negated
compress_normalize_protocols_step_not_introduces_Prot_negated by auto
lemma compress_normalize_protocols_hasdisc:
"¬ has_disc disc m ⟹ (∀a. ¬ disc (Prot a)) ⟹ normalized_nnf_match m ⟹ compress_normalize_protocols m = Some m' ⟹
normalized_nnf_match m' ∧ ¬ has_disc disc m'"
apply(simp add: compress_normalize_protocols_def)
using import_protocols_from_ports_hasdisc
compress_normalize_protocols_step_hasdisc by blast
lemma compress_normalize_protocols_hasdisc_negated:
"¬ has_disc_negated disc False m ⟹ (∀a. ¬ disc (Prot a)) ⟹
normalized_nnf_match m ⟹ compress_normalize_protocols m = Some m' ⟹
normalized_nnf_match m' ∧ ¬ has_disc_negated disc False m'"
apply(simp add: compress_normalize_protocols_def)
apply(frule(2) import_protocols_from_ports_hasdisc_negated)
using compress_normalize_protocols_step_hasdisc_negated by blast
lemma compress_normalize_protocols_preserves_normalized_n_primitive:
"normalized_n_primitive (disc, sel) P m ⟹ (∀a. ¬ disc (Prot a)) ⟹ normalized_nnf_match m ⟹ compress_normalize_protocols m = Some m' ⟹
normalized_nnf_match m' ∧ normalized_n_primitive (disc, sel) P m'"
apply(simp add: compress_normalize_protocols_def)
using import_protocols_from_ports_preserves_normalized_n_primitive
compress_normalize_protocols_step_preserves_normalized_n_primitive by blast
lemma "case compress_normalize_protocols
(MatchAnd (MatchAnd (MatchAnd (Match ((Prot (Proto TCP)):: 32 common_primitive)) (MatchNot (Match (Prot (Proto UDP))))) (Match (IIface (Iface ''eth1''))))
(Match (Prot (Proto TCP)))) of Some ps ⇒ opt_MatchAny_match_expr ps
=
MatchAnd (Match (Prot (Proto 6))) (Match (IIface (Iface ''eth1'')))" by eval
value[code] "compress_normalize_protocols (MatchAny:: 32 common_primitive match_expr)"
end
Theory Remdups_Rev
section‹Reverse Remdups›
theory Remdups_Rev
imports Main
begin
definition remdups_rev :: "'a list ⇒ 'a list" where
"remdups_rev rs ≡ rev (remdups (rev rs))"
lemma remdups_append: "remdups (rs @ rs2) = remdups [r←rs . r ∉ set rs2] @ remdups rs2"
by(induction rs arbitrary: rs2) (simp_all)
lemma remdups_rev_append: "remdups_rev (rs @ rs2) = remdups_rev rs @ remdups_rev [r←rs2 . r ∉ set rs]"
proof(induction rs arbitrary: rs2)
case Cons thus ?case by(simp add: remdups_append rev_filter remdups_rev_def)
qed(simp add: remdups_rev_def)
lemma remdups_rev_fst:
"remdups_rev (r#rs) = (if r ∈ set rs then r#remdups_rev (removeAll r rs) else r#remdups_rev rs)"
proof -
have 1: "r ∉ set rs ⟹ remdups_rev (r # rs) = r # remdups_rev rs"
unfolding remdups_rev_def
proof(induction rs)
case (Cons r rs)
{ fix rs and rs2::"'a list"
have "set rs ∩ set rs2 = {} ⟹ remdups (rs @ rs2) = remdups rs @ remdups rs2"
by(induction rs arbitrary: rs2) (simp_all)
} note h=this
{ fix r and rs::"'a list"
from h[of "rev rs" "[r]"] have "r ∉ set rs ⟹ remdups (rev rs @ [r]) = remdups (rev rs) @ [r]" by simp
}
with Cons show ?case by fastforce
qed(simp)
have 2: "r ∈ set rs ⟹ remdups_rev (r # rs) = r # remdups_rev (rev (removeAll r (rev rs)))"
unfolding remdups_rev_def
proof(induction rs)
case Cons thus ?case
apply(simp add: removeAll_filter_not_eq remdups_append)
apply(safe)
apply(simp_all)
apply metis
apply metis
done
qed(simp)
have "rev (removeAll r (rev rs)) = removeAll r rs" by (simp add: removeAll_filter_not_eq rev_filter)
with 1 2 show ?thesis by simp
qed
lemma remdups_rev_set: "set (remdups_rev rs) = set rs" by (simp add: remdups_rev_def)
lemma remdups_rev_removeAll: "remdups_rev (removeAll r rs) = removeAll r (remdups_rev rs)"
by (simp add: remdups_filter remdups_rev_def removeAll_filter_not_eq rev_filter)
text‹Faster code equations›
fun remdups_rev_code :: "'a list ⇒ 'a list ⇒ 'a list" where
"remdups_rev_code _ [] = []" |
"remdups_rev_code ps (r#rs) = (if r ∈ set ps then remdups_rev_code ps rs else r#remdups_rev_code (r#ps) rs)"
lemma remdups_rev_code[code_unfold]: "remdups_rev rs = remdups_rev_code [] rs"
proof -
{ fix ps1 ps2 p and rs::"'a list"
have "set ps1 = set ps2 ⟹ remdups_rev_code ps1 rs = remdups_rev_code ps2 rs"
proof(induction rs arbitrary: ps1 ps2)
case Nil thus ?case by simp
next
case (Cons r rs) show ?case
apply(subst remdups_rev_code.simps)+
apply(case_tac "r ∈ set ps1")
using Cons apply metis
using Cons apply(simp)
done
qed
} note remdups_rev_code_ps_seteq=this
{ fix ps1 ps2 p and rs::"'a list"
have "remdups_rev_code (ps1@ps2) rs = remdups_rev_code ps2 (filter (λr. r ∉ set ps1) rs)"
proof(induction rs arbitrary: ps1 ps2)
case (Cons r rs)
have "remdups_rev_code (r # ps1 @ ps2) rs = remdups_rev_code (ps1 @ r # ps2) rs"
by(rule remdups_rev_code_ps_seteq) simp
with Cons.IH have "remdups_rev_code (r # ps1 @ ps2) rs = remdups_rev_code (r#ps2) [r←rs . r ∉ set ps1]" by simp
from this show ?case by(simp add: Cons)
qed(simp add: remdups_rev_def)
} note remdups_rev_code_ps_append=this
{ fix ps p and rs::"'a list"
have "remdups_rev_code (p # ps) rs = remdups_rev_code ps (removeAll p rs)"
by(simp add: remdups_rev_code_ps_append[of "[p]" "ps" rs, simplified] removeAll_filter_not_eq) metis
} note remdups_rev_code_ps_fst=this
{ fix ps p and rs::"'a list"
have "remdups_rev_code ps (removeAll p rs) = removeAll p (remdups_rev_code ps rs)"
apply(induction rs arbitrary: ps)
apply(simp_all)
apply(safe)
apply(simp_all)
apply(simp add: remdups_rev_code_ps_fst removeAll_filter_not_eq)
done
} note remdups_rev_code_removeAll=this
{fix ps
have "∀p ∈ set ps. p ∉ set rs ⟹ remdups_rev rs = remdups_rev_code ps rs"
apply(induction rs arbitrary: ps)
apply(simp add: remdups_rev_def)
apply(simp add: remdups_rev_fst remdups_rev_removeAll)
apply safe
apply(simp_all)
apply(simp add: remdups_rev_code_ps_fst remdups_rev_code_removeAll)
apply metis
by blast
}
thus ?thesis by simp
qed
end
Theory Ipassmt
theory Ipassmt
imports Common_Primitive_Syntax
"../Semantics_Ternary/Primitive_Normalization"
Simple_Firewall.Iface
Simple_Firewall.IP_Addr_WordInterval_toString
Automatic_Refinement.Misc
begin
hide_const Misc.uncurry
hide_fact Misc.uncurry_def
text‹A mapping from an interface to its assigned ip addresses in CIDR notation›
type_synonym 'i ipassignment="iface ⇀ ('i word × nat) list"
subsection‹Sanity checking for an @{typ "'i ipassignment"}.›
text‹warning if interface map has wildcards›
definition ipassmt_sanity_nowildcards :: "'i ipassignment ⇒ bool" where
"ipassmt_sanity_nowildcards ipassmt ≡ ∀ iface ∈ dom ipassmt. ¬ iface_is_wildcard iface"
text‹Executable of the @{typ "'i ipassignment"} is given as a list.›
lemma[code_unfold]: "ipassmt_sanity_nowildcards (map_of ipassmt) ⟷ (∀ iface ∈ fst` set ipassmt. ¬ iface_is_wildcard iface)"
by(simp add: ipassmt_sanity_nowildcards_def Map.dom_map_of_conv_image_fst)
lemma ipassmt_sanity_nowildcards_match_iface:
"ipassmt_sanity_nowildcards ipassmt ⟹
ipassmt (Iface ifce2) = None ⟹
ipassmt ifce = Some a ⟹
¬ match_iface ifce ifce2"
unfolding ipassmt_sanity_nowildcards_def using iface_is_wildcard_def match_iface_case_nowildcard by fastforce
definition map_of_ipassmt :: "(iface × ('i word × nat) list) list ⇒ iface ⇀ ('i word × nat) list" where
"map_of_ipassmt ipassmt = (
if
distinct (map fst ipassmt) ∧ ipassmt_sanity_nowildcards (map_of ipassmt)
then
map_of ipassmt
else undefined )"
text‹some additional (optional) sanity checks›
text‹sanity check that there are no zone-spanning interfaces›
definition ipassmt_sanity_disjoint :: "'i::len ipassignment ⇒ bool" where
"ipassmt_sanity_disjoint ipassmt ≡ ∀ i1 ∈ dom ipassmt. ∀ i2 ∈ dom ipassmt. i1 ≠ i2 ⟶
ipcidr_union_set (set (the (ipassmt i1))) ∩ ipcidr_union_set (set (the (ipassmt i2))) = {}"
lemma[code_unfold]: "ipassmt_sanity_disjoint (map_of ipassmt) ⟷
(let Is = fst` set ipassmt in
(∀ i1 ∈ Is. ∀ i2 ∈ Is. i1 ≠ i2 ⟶ wordinterval_empty (wordinterval_intersection (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1)))) (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))))"
apply(simp add: ipassmt_sanity_disjoint_def Map.dom_map_of_conv_image_fst)
apply(simp add: ipcidr_union_set_def)
apply(simp add: l2wi)
apply(simp add: ipcidr_to_interval_def)
using ipset_from_cidr_ipcidr_to_interval by blast
text‹Checking that the ipassmt covers the complete ipv4 address space.›
definition ipassmt_sanity_complete :: "(iface × ('i::len word × nat) list) list ⇒ bool" where
"ipassmt_sanity_complete ipassmt ≡ distinct (map fst ipassmt) ∧ (⋃(ipcidr_union_set ` set ` (ran (map_of ipassmt)))) = UNIV"
lemma[code_unfold]: "ipassmt_sanity_complete ipassmt ⟷ distinct (map fst ipassmt) ∧ (let range = map snd ipassmt in
wordinterval_eq (wordinterval_Union (map (l2wi ∘ (map ipcidr_to_interval)) range)) wordinterval_UNIV
)"
apply(cases "distinct (map fst ipassmt)")
apply(simp add: ipassmt_sanity_complete_def)
apply(simp add: Map.ran_distinct)
apply(simp add: wordinterval_eq_set_eq wordinterval_Union)
apply(simp add: l2wi)
apply(simp add: ipcidr_to_interval_def)
apply(simp add: ipcidr_union_set_def ipset_from_cidr_ipcidr_to_interval; fail)
apply(simp add: ipassmt_sanity_complete_def)
done
value[code] "ipassmt_sanity_nowildcards (map_of [(Iface ''eth1.1017'', [(ipv4addr_of_dotdecimal (131,159,14,240), 28)])])"
fun collect_ifaces' :: "'i::len common_primitive rule list ⇒ iface list" where
"collect_ifaces' [] = []" |
"collect_ifaces' ((Rule m a)#rs) = filter (λiface. iface ≠ ifaceAny) (
(map (λx. case x of Pos i ⇒ i | Neg i ⇒ i) (fst (primitive_extractor (is_Iiface, iiface_sel) m))) @
(map (λx. case x of Pos i ⇒ i | Neg i ⇒ i) (fst (primitive_extractor (is_Oiface, oiface_sel) m))) @ collect_ifaces' rs)"
definition collect_ifaces :: "'i::len common_primitive rule list ⇒ iface list" where
"collect_ifaces rs ≡ mergesort_remdups (collect_ifaces' rs)"
lemma "set (collect_ifaces rs) = set (collect_ifaces' rs)"
by(simp add: collect_ifaces_def mergesort_remdups_correct)
text‹sanity check that all interfaces mentioned in the ruleset are also listed in the ipassmt. May fail for wildcard interfaces in the ruleset.›
definition ipassmt_sanity_defined :: "'i::len common_primitive rule list ⇒ 'i ipassignment ⇒ bool" where
"ipassmt_sanity_defined rs ipassmt ≡ ∀ iface ∈ set (collect_ifaces rs). iface ∈ dom ipassmt"
lemma[code]: "ipassmt_sanity_defined rs ipassmt ⟷ (∀ iface ∈ set (collect_ifaces rs). ipassmt iface ≠ None)"
by(simp add: ipassmt_sanity_defined_def Map.domIff)
lemma "ipassmt_sanity_defined [
Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (Iface ''eth1.1017'')))) action.Accept,
Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (ifaceAny)))) action.Accept,
Rule MatchAny action.Drop]
(map_of [(Iface ''eth1.1017'', [(ipv4addr_of_dotdecimal (131,159,14,240), 28)])])" by eval
definition ipassmt_ignore_wildcard :: "'i::len ipassignment ⇒ 'i ipassignment" where
"ipassmt_ignore_wildcard ipassmt ≡ λk. case ipassmt k of None ⇒ None
| Some ips ⇒ if ipcidr_union_set (set ips) = UNIV then None else Some ips"
lemma ipassmt_ignore_wildcard_le: "ipassmt_ignore_wildcard ipassmt ⊆⇩m ipassmt"
apply(simp add: ipassmt_ignore_wildcard_def map_le_def)
apply(clarify)
apply(simp split: option.split_asm if_split_asm)
done
definition ipassmt_ignore_wildcard_list:: "(iface × ('i::len word × nat) list) list ⇒ (iface × ('i word × nat) list) list" where
"ipassmt_ignore_wildcard_list ipassmt = filter (λ(_,ips). ¬ wordinterval_eq (l2wi (map ipcidr_to_interval ips)) wordinterval_UNIV) ipassmt"
lemma "distinct (map fst ipassmt) ⟹
map_of (ipassmt_ignore_wildcard_list ipassmt) = ipassmt_ignore_wildcard (map_of ipassmt)"
apply(simp add: ipassmt_ignore_wildcard_list_def ipassmt_ignore_wildcard_def)
apply(simp add: wordinterval_eq_set_eq)
apply(simp add: l2wi)
apply(simp add: ipcidr_to_interval_def)
apply(simp add: fun_eq_iff)
apply(clarify)
apply(induction ipassmt)
apply(simp; fail)
apply(simp)
apply(simp split:option.split option.split_asm)
apply(simp add: ipcidr_union_set_def ipset_from_cidr_ipcidr_to_interval)
apply(simp add: case_prod_unfold)
by blast
text‹Debug algorithm with human-readable output›
definition debug_ipassmt_generic
:: "('i::len wordinterval ⇒ string) ⇒
(iface × ('i word × nat) list) list ⇒ 'i common_primitive rule list ⇒ string list" where
"debug_ipassmt_generic toStr ipassmt rs ≡ let ifaces = (map fst ipassmt) in [
''distinct: '' @ (if distinct ifaces then ''passed'' else ''FAIL!'')
, ''ipassmt_sanity_nowildcards: '' @
(if ipassmt_sanity_nowildcards (map_of ipassmt)
then ''passed'' else ''fail: ''@list_toString iface_sel (filter iface_is_wildcard ifaces))
, ''ipassmt_sanity_defined (interfaces defined in the ruleset are also in ipassmt): '' @
(if ipassmt_sanity_defined rs (map_of ipassmt)
then ''passed'' else ''fail: ''@list_toString iface_sel [i ← (collect_ifaces rs). i ∉ set ifaces])
, ''ipassmt_sanity_disjoint (no zone-spanning interfaces): '' @
(if ipassmt_sanity_disjoint (map_of ipassmt)
then ''passed'' else ''fail: ''@list_toString (λ(i1,i2). ''('' @ iface_sel i1 @ '','' @ iface_sel i2 @ '')'')
[(i1,i2) ← List.product ifaces ifaces. i1 ≠ i2 ∧
¬ wordinterval_empty (wordinterval_intersection
(l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1))))
(l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))
])
, ''ipassmt_sanity_disjoint excluding UNIV interfaces: '' @
(let ipassmt = ipassmt_ignore_wildcard_list ipassmt;
ifaces = (map fst ipassmt)
in
(if ipassmt_sanity_disjoint (map_of ipassmt)
then ''passed'' else ''fail: ''@list_toString (λ(i1,i2). ''('' @ iface_sel i1 @ '','' @ iface_sel i2 @ '')'')
[(i1,i2) ← List.product ifaces ifaces. i1 ≠ i2 ∧
¬ wordinterval_empty (wordinterval_intersection
(l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1))))
(l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))
]))
, ''ipassmt_sanity_complete: '' @
(if ipassmt_sanity_complete ipassmt
then ''passed''
else ''the following is not covered: '' @
toStr (wordinterval_setminus wordinterval_UNIV (wordinterval_Union (map (l2wi ∘ (map ipcidr_to_interval)) (map snd ipassmt)))))
, ''ipassmt_sanity_complete excluding UNIV interfaces: '' @
(let ipassmt = ipassmt_ignore_wildcard_list ipassmt
in
(if ipassmt_sanity_complete ipassmt
then ''passed''
else ''the following is not covered: '' @
toStr (wordinterval_setminus wordinterval_UNIV (wordinterval_Union (map (l2wi ∘ (map ipcidr_to_interval)) (map snd ipassmt))))))
]"
definition "debug_ipassmt_ipv4 ≡ debug_ipassmt_generic ipv4addr_wordinterval_toString"
definition "debug_ipassmt_ipv6 ≡ debug_ipassmt_generic ipv6addr_wordinterval_toString"
lemma dom_ipassmt_ignore_wildcard:
"i∈dom (ipassmt_ignore_wildcard ipassmt) ⟷ i ∈ dom ipassmt ∧ ipcidr_union_set (set (the (ipassmt i))) ≠ UNIV"
apply(simp add: ipassmt_ignore_wildcard_def)
apply(rule)
apply(clarify)
apply(simp split: option.split_asm if_split_asm)
apply blast
apply(clarify)
apply(simp)
done
lemma ipassmt_ignore_wildcard_the:
"ipassmt i = Some ips ⟹ ipcidr_union_set (set ips) ≠ UNIV ⟹ (the (ipassmt_ignore_wildcard ipassmt i)) = ips"
"ipassmt_ignore_wildcard ipassmt i = Some ips ⟹ the (ipassmt i) = ips"
"ipassmt_ignore_wildcard ipassmt i = Some ips ⟹ ipcidr_union_set (set ips) ≠ UNIV"
by (simp_all add: ipassmt_ignore_wildcard_def split: option.split_asm if_split_asm)
lemma ipassmt_sanity_disjoint_ignore_wildcards:
"ipassmt_sanity_disjoint (ipassmt_ignore_wildcard ipassmt) ⟷
(∀i1∈dom ipassmt.
∀i2∈dom ipassmt.
ipcidr_union_set (set (the (ipassmt i1))) ≠ UNIV ∧
ipcidr_union_set (set (the (ipassmt i2))) ≠ UNIV ∧
i1 ≠ i2
⟶ ipcidr_union_set (set (the (ipassmt i1))) ∩ ipcidr_union_set (set (the (ipassmt i2))) = {})"
apply(simp add: ipassmt_sanity_disjoint_def)
apply(rule)
apply(clarify)
apply(simp)
subgoal for i1 i2 ips1 ips2
apply(erule_tac x=i1 in ballE)
prefer 2
using dom_ipassmt_ignore_wildcard apply (metis domI option.sel)
apply(erule_tac x=i2 in ballE)
prefer 2
using dom_ipassmt_ignore_wildcard apply (metis domI domIff option.sel)
by(simp add: ipassmt_ignore_wildcard_the; fail)
apply(clarify)
apply(simp)
subgoal for i1 i2 ips1 ips2
apply(erule_tac x=i1 in ballE)
prefer 2
using dom_ipassmt_ignore_wildcard apply auto[1]
apply(erule_tac x=i2 in ballE)
prefer 2
using dom_ipassmt_ignore_wildcard apply auto[1]
by(simp add: ipassmt_ignore_wildcard_the)
done
text‹Confusing names: @{const ipassmt_sanity_nowildcards} refers to wildcard interfaces.
@{const ipassmt_ignore_wildcard} refers to the UNIV ip range.
›
lemma ipassmt_sanity_nowildcards_ignore_wildcardD:
"ipassmt_sanity_nowildcards ipassmt ⟹ ipassmt_sanity_nowildcards (ipassmt_ignore_wildcard ipassmt)"
by (simp add: dom_ipassmt_ignore_wildcard ipassmt_sanity_nowildcards_def)
lemma ipassmt_disjoint_nonempty_inj:
assumes ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
and ifce: "ipassmt ifce = Some i_ips"
and a: "ipcidr_union_set (set i_ips) ≠ {}"
and k: "ipassmt k = Some i_ips"
shows "k = ifce"
proof(rule ccontr)
assume "k ≠ ifce"
with ifce k ipassmt_disjoint have "ipcidr_union_set (set (the (ipassmt k))) ∩ ipcidr_union_set (set (the (ipassmt ifce))) = {}"
unfolding ipassmt_sanity_disjoint_def by fastforce
thus False using a ifce k by auto
qed
lemma ipassmt_ignore_wildcard_None_Some:
"ipassmt_ignore_wildcard ipassmt ifce = None ⟹ ipassmt ifce = Some ips ⟹ ipcidr_union_set (set ips) = UNIV"
by (metis domI domIff dom_ipassmt_ignore_wildcard option.sel)
lemma ipassmt_disjoint_ignore_wildcard_nonempty_inj:
assumes ipassmt_disjoint: "ipassmt_sanity_disjoint (ipassmt_ignore_wildcard ipassmt)"
and ifce: "ipassmt ifce = Some i_ips"
and a: "ipcidr_union_set (set i_ips) ≠ {}"
and k: "(ipassmt_ignore_wildcard ipassmt) k = Some i_ips"
shows "k = ifce"
proof(rule ccontr)
assume "k ≠ ifce"
show False
proof(cases "(ipassmt_ignore_wildcard ipassmt) ifce")
case (Some i_ips')
hence "i_ips' = i_ips" using ifce ipassmt_ignore_wildcard_the(2) by fastforce
hence "(ipassmt_ignore_wildcard ipassmt) k = Some i_ips" using Some ifce ipassmt_ignore_wildcard_def k by auto
thus False using Some ‹i_ips' = i_ips› ‹k ≠ ifce› a ipassmt_disjoint ipassmt_disjoint_nonempty_inj by blast
next
case None
with ipassmt_ignore_wildcard_None_Some have "ipcidr_union_set (set i_ips) = UNIV" using ifce by auto
thus False using ipassmt_ignore_wildcard_the(3) k by blast
qed
qed
lemma ipassmt_disjoint_inj_k:
assumes ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
and ifce: "ipassmt ifce = Some ips"
and k: "ipassmt k = Some ips'"
and a: "p ∈ ipcidr_union_set (set ips)"
and b: "p ∈ ipcidr_union_set (set ips')"
shows "k = ifce"
proof(rule ccontr)
assume "k ≠ ifce"
with ipassmt_disjoint have
"ipcidr_union_set (set (the (ipassmt k))) ∩ ipcidr_union_set (set (the (ipassmt ifce))) = {}"
unfolding ipassmt_sanity_disjoint_def using ifce k by blast
hence "ipcidr_union_set (set ips') ∩ ipcidr_union_set (set ips) = {}" by(simp add: k ifce)
thus False using a b by blast
qed
lemma ipassmt_disjoint_matcheq_iifce_srcip:
assumes ipassmt_nowild: "ipassmt_sanity_nowildcards ipassmt"
and ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
and ifce: "ipassmt ifce = Some i_ips"
and p_ifce: "ipassmt (Iface (p_iiface p)) = Some p_ips ∧ p_src p ∈ ipcidr_union_set (set p_ips)"
shows "match_iface ifce (p_iiface p) ⟷ p_src p ∈ ipcidr_union_set (set i_ips)"
proof
assume "match_iface ifce (p_iiface p)"
thus "p_src p ∈ ipcidr_union_set (set i_ips)"
apply(cases "ifce = Iface (p_iiface p)")
using ifce p_ifce apply force
by (metis domI iface.sel iface_is_wildcard_def ifce ipassmt_nowild ipassmt_sanity_nowildcards_def match_iface.elims(2) match_iface_case_nowildcard)
next
assume a: "p_src p ∈ ipcidr_union_set (set i_ips)"
from ipassmt_disjoint_nonempty_inj[OF ipassmt_disjoint ifce] a have ipassmt_inj: "∀k. ipassmt k = Some i_ips ⟶ k = ifce" by blast
from ipassmt_disjoint_inj_k[OF ipassmt_disjoint ifce _ a] have ipassmt_inj_k:
"⋀k ips'. ipassmt k = Some ips' ⟹ p_src p ∈ ipcidr_union_set (set ips') ⟹ k = ifce" by simp
have ipassmt_inj_p: "∀ips'. p_src p ∈ ipcidr_union_set (set ips') ∧ (∃k. ipassmt k = Some ips') ⟶ ips' = i_ips"
apply(clarify)
apply(rename_tac ips' k)
apply(subgoal_tac "k = ifce")
using ifce apply simp
using ipassmt_inj_k by simp
from p_ifce have "(Iface (p_iiface p)) = ifce" using ipassmt_inj_p ipassmt_inj by blast
thus "match_iface ifce (p_iiface p)" using match_iface_refl by blast
qed
definition ipassmt_generic_ipv4 :: "(iface × (32 word × nat) list) list" where
"ipassmt_generic_ipv4 = [(Iface ''lo'', [(ipv4addr_of_dotdecimal (127,0,0,0),8)])]"
definition ipassmt_generic_ipv6 :: "(iface × (128 word × nat) list) list" where
"ipassmt_generic_ipv6 = [(Iface ''lo'', [(1,128)])]"
subsection‹IP Assignment difference›
text‹Compare two ipassmts. Returns a list of tuples
First entry of the tuple: things which are in the left ipassmt but not in the right.
Second entry of the tupls: things which are in the right ipassmt but not in the left.›
definition ipassmt_diff
:: "(iface × ('i::len word × nat) list) list ⇒ (iface × ('i::len word × nat) list) list
⇒ (iface × ('i word × nat) list × ('i word × nat) list) list"
where
"ipassmt_diff a b ≡ let
t = λs. (case s of None ⇒ Empty_WordInterval
| Some s ⇒ wordinterval_Union (map ipcidr_tuple_to_wordinterval s));
k = λx y d. cidr_split (wordinterval_setminus (t (map_of x d)) (t (map_of y d)))
in
[(d, (k a b d, k b a d)). d ← remdups (map fst (a @ b))]"
text‹If an interface is defined in both ipassignments and there is no difference
then the two ipassignements describe the same IP range for this interface.›
lemma ipassmt_diff_ifce_equal: "(ifce, [], []) ∈ set (ipassmt_diff ipassmt1 ipassmt2) ⟹
ifce ∈ dom (map_of ipassmt1) ⟹ ifce ∈ dom (map_of ipassmt2) ⟹
ipcidr_union_set (set (the ((map_of ipassmt1) ifce))) =
ipcidr_union_set (set (the ((map_of ipassmt2) ifce)))"
proof -
have cidr_empty: "[] = cidr_split r ⟹ wordinterval_to_set r = {}" for r :: "'a wordinterval"
apply(subst cidr_split_prefix[symmetric])
by(simp)
show "(ifce, [], []) ∈ set (ipassmt_diff ipassmt1 ipassmt2) ⟹
ifce ∈ dom (map_of ipassmt1) ⟹ ifce ∈ dom (map_of ipassmt2) ⟹
ipcidr_union_set (set (the ((map_of ipassmt1) ifce))) =
ipcidr_union_set (set (the ((map_of ipassmt2) ifce)))"
apply(simp add: ipassmt_diff_def Let_def ipcidr_union_set_uncurry)
apply(simp add: Set.image_iff)
apply(elim conjE)
apply(drule cidr_empty)+
apply(simp)
apply(simp add: domIff)
apply(elim exE)
apply(simp add: wordinterval_Union wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry)
done
qed
lemma ipcidr_union_cidr_split[simp]: "ipcidr_union_set (set (cidr_split a)) = wordinterval_to_set a"
by(simp add: ipcidr_union_set_uncurry cidr_split_prefix)
lemma
defines "assmt as ifce ≡ ipcidr_union_set (set (the ((map_of as ifce))))"
assumes diffs: "(ifce, d1, d2) ∈ set (ipassmt_diff ipassmt1 ipassmt2)"
and doms: "ifce ∈ dom (map_of ipassmt1)" "ifce ∈ dom (map_of ipassmt2)"
shows "ipcidr_union_set (set d1) = assmt ipassmt1 ifce - assmt ipassmt2 ifce"
"ipcidr_union_set (set d2) = assmt ipassmt2 ifce - assmt ipassmt1 ifce"
using assms by (clarsimp simp add: ipassmt_diff_def Let_def assmt_def wordinterval_Union; simp add: ipcidr_union_set_uncurry uncurry_def wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry)+
text‹Explanation for interface @{term "Iface ''a''"}:
Left ipassmt: The IP range 4/30 contains the addresses 4,5,6,7
Diff: right ipassmt contains 6/32, so 4,5,7 is only in the left ipassmt.
IP addresses 4,5 correspond to subnet 4/30.›
lemma "ipassmt_diff (ipassmt_generic_ipv4 @ [(Iface ''a'', [(4,30)])])
(ipassmt_generic_ipv4 @ [(Iface ''a'', [(6,32), (0,30)]), (Iface ''b'', [(42,32)])]) =
[(Iface ''lo'', [], []),
(Iface ''a'', [(4, 31),(7, 32)],
[(0, 30)]
),
(Iface ''b'', [], [(42, 32)])]" by eval
end
Theory No_Spoof
theory No_Spoof
imports Common_Primitive_Lemmas
Ipassmt
begin
section‹No Spoofing›
text‹assumes: @{const simple_ruleset}›
subsection‹Spoofing Protection›
text‹
No spoofing means:
Every packet that is (potentially) allowed by the firewall and comes from an interface ‹iface›
must have a Source IP Address in the assigned range ‹iface›.
``potentially allowed'' means we use the upper closure.
The definition states: For all interfaces which are configured, every packet that comes from this
interface and is allowed by the firewall must be in the IP range of that interface.
›
text‹We add @{typ "'pkt_ext itself"} as a parameter to have the type of a generic, extensible packet
in the definition.›
definition no_spoofing :: "'pkt_ext itself ⇒ 'i::len ipassignment ⇒ 'i::len common_primitive rule list ⇒ bool" where
"no_spoofing TYPE('pkt_ext) ipassmt rs ≡ ∀ iface ∈ dom ipassmt. ∀p :: ('i,'pkt_ext) tagged_packet_scheme.
((common_matcher, in_doubt_allow),p⦇p_iiface:=iface_sel iface⦈⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow) ⟶
p_src p ∈ (ipcidr_union_set (set (the (ipassmt iface))))"
text ‹This is how it looks like for an IPv4 simple packet: We add @{type unit} because a
@{typ "32 tagged_packet"} does not have any additional fields.›
lemma "no_spoofing TYPE(unit) ipassmt rs ⟷
(∀ iface ∈ dom ipassmt. ∀p :: 32 tagged_packet.
((common_matcher, in_doubt_allow),p⦇p_iiface:=iface_sel iface⦈⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow)
⟶ p_src p ∈ (ipcidr_union_set (set (the (ipassmt iface)))))"
unfolding no_spoofing_def by blast
text‹The definition is sound (if that can be said about a definition):
if @{const no_spoofing} certifies your ruleset, then your ruleset prohibits spoofing.
The definition may not be complete:
@{const no_spoofing} may return @{const False} even though your ruleset prevents spoofing
(should only occur if some strange and unknown primitives occur)›
text‹Technical note: The definition can can be thought of as protection from OUTGOING spoofing.
OUTGOING means: I define my interfaces and their IP addresses. For all interfaces,
only the assigned IP addresses may pass the firewall.
This definition is simple for e.g. local sub-networks.
Example: @{term "[Iface ''eth0'' ↦ {(ipv4addr_of_dotdecimal (192,168,0,0), 24)}]"}
If I want spoofing protection from the Internet, I need to specify the range of the Internet IP addresses.
Example: @{term "[Iface ''evil_internet'' ↦ {everything_that_does_not_belong_to_me}]"}.
This is also a good opportunity to exclude the private IP space, link local, and probably multicast space.
See @{const all_but_those_ips} to easily specify these ranges.
See examples below. Check Example 3 why it can be thought of as OUTGOING spoofing.›
context
begin
text‹The set of any ip addresses which may match for a fixed ‹iface› (overapproximation)›
private definition get_exists_matching_src_ips :: "iface ⇒ 'i::len common_primitive match_expr ⇒ 'i word set" where
"get_exists_matching_src_ips iface m ≡ let (i_matches, _) = (primitive_extractor (is_Iiface, iiface_sel) m) in
if (∀ is ∈ set i_matches. (case is of Pos i ⇒ match_iface i (iface_sel iface)
| Neg i ⇒ ¬ match_iface i (iface_sel iface)))
then
(let (ip_matches, _) = (primitive_extractor (is_Src, src_sel) m) in
if ip_matches = []
then
UNIV
else
⋂ ips ∈ set (ip_matches). (case ips of Pos ip ⇒ ipt_iprange_to_set ip | Neg ip ⇒ - ipt_iprange_to_set ip))
else
{}"
lemma "primitive_extractor (is_Src, src_sel)
(MatchAnd (Match (Src (IpAddrNetmask (0::ipv4addr) 30))) (Match (IIface (Iface ''eth0'')))) =
([Pos (IpAddrNetmask 0 30)], MatchAnd MatchAny (Match (IIface (Iface ''eth0''))))" by eval
private lemma get_exists_matching_src_ips_subset:
assumes "normalized_nnf_match m"
shows "{ip. (∃p :: ('i::len, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (p⦇p_iiface:= iface_sel iface, p_src:= ip⦈))} ⊆
get_exists_matching_src_ips iface m"
proof -
let ?γ="(common_matcher, in_doubt_allow)"
{ fix ip_matches rest src_ip i_matches rest2 and p :: "('i, 'a) tagged_packet_scheme"
assume a1: "primitive_extractor (is_Src, src_sel) m = (ip_matches, rest)"
and a2: "matches ?γ m a (p⦇p_iiface := iface_sel iface, p_src := src_ip⦈)"
let ?p="(p⦇p_iiface := iface_sel iface, p_src := src_ip⦈)"
from primitive_extractor_negation_type_matching1[OF wf_disc_sel_common_primitive(3) assms a1 a2]
match_simplematcher_SrcDst[where p = ?p] match_simplematcher_SrcDst_not[where p="?p"]
have ip_matches: "(∀ip∈set (getPos ip_matches). p_src ?p ∈ ipt_iprange_to_set ip) ∧
(∀ip∈set (getNeg ip_matches). p_src ?p ∈ - ipt_iprange_to_set ip)" by simp
from ip_matches have "∀x ∈ set ip_matches. src_ip ∈ (case x of Pos x ⇒ ipt_iprange_to_set x | Neg ip ⇒ - ipt_iprange_to_set ip)"
apply(simp)
apply(simp split: negation_type.split)
apply(safe)
using NegPos_set apply fast+
done
} note 1=this
{ fix ip_matches rest src_ip i_matches rest2 and p :: "('i, 'a) tagged_packet_scheme"
assume a1: "primitive_extractor (is_Iiface, iiface_sel) m = (i_matches, rest2)"
and a2: "matches ?γ m a (p⦇p_iiface := iface_sel iface, p_src := src_ip⦈)"
let ?p="(p⦇p_iiface := iface_sel iface, p_src := src_ip⦈)"
from primitive_extractor_negation_type_matching1[OF wf_disc_sel_common_primitive(5) assms a1 a2]
primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher, where p = ?p]
primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher, where p = ?p]
have iface_matches: "(∀i∈set (getPos i_matches). match_iface i (p_iiface ?p)) ∧
(∀i∈set (getNeg i_matches). ¬ match_iface i (p_iiface ?p))" by simp
hence 2: "(∀x∈set i_matches. case x of Pos i ⇒ match_iface i (iface_sel iface) | Neg i ⇒ ¬ match_iface i (iface_sel iface))"
apply(simp add: split: negation_type.split)
apply(safe)
using NegPos_set apply fast+
done
} note 2=this
from 1 2 show ?thesis
unfolding get_exists_matching_src_ips_def
by(clarsimp)
qed
lemma common_primitive_not_has_primitive_expand:
"¬ has_primitive (m::'i::len common_primitive match_expr) ⟷
¬ has_disc is_Dst m ∧
¬ has_disc is_Src m ∧
¬ has_disc is_Iiface m ∧
¬ has_disc is_Oiface m ∧
¬ has_disc is_Prot m ∧
¬ has_disc is_Src_Ports m ∧
¬ has_disc is_Dst_Ports m ∧
¬ has_disc is_MultiportPorts m ∧
¬ has_disc is_L4_Flags m ∧
¬ has_disc is_CT_State m ∧
¬ has_disc is_Extra m"
apply(induction m)
apply(simp_all)
apply(rename_tac x, case_tac x, simp_all)
by blast
lemma "¬ has_primitive m ∧ matcheq_matchAny m ⟷ (if ¬ has_primitive m then matcheq_matchAny m else False)"
by simp
text‹The set of ip addresses which definitely match for a fixed ‹iface› (underapproximation)›
private definition get_all_matching_src_ips :: "iface ⇒ 'i::len common_primitive match_expr ⇒ 'i word set" where
"get_all_matching_src_ips iface m ≡ let (i_matches, rest1) = (primitive_extractor (is_Iiface, iiface_sel) m) in
if (∀ is ∈ set i_matches. (case is of Pos i ⇒ match_iface i (iface_sel iface)
| Neg i ⇒ ¬ match_iface i (iface_sel iface)))
then
(let (ip_matches, rest2) = (primitive_extractor (is_Src, src_sel) rest1) in
if ¬ has_primitive rest2 ∧ matcheq_matchAny rest2
then
if ip_matches = []
then
UNIV
else
⋂ ips ∈ set (ip_matches). (case ips of Pos ip ⇒ ipt_iprange_to_set ip | Neg ip ⇒ - ipt_iprange_to_set ip)
else
{})
else
{}"
private lemma get_all_matching_src_ips:
assumes "normalized_nnf_match m"
shows "get_all_matching_src_ips iface m ⊆
{ip. (∀p::('i::len, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (p⦇p_iiface:= iface_sel iface, p_src:= ip⦈))}"
proof
fix ip
assume a: "ip ∈ get_all_matching_src_ips iface m"
obtain i_matches rest1 where select1: "primitive_extractor (is_Iiface, iiface_sel) m = (i_matches, rest1)" by fastforce
show "ip ∈ {ip. ∀p :: ('i, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (p⦇p_iiface := iface_sel iface, p_src := ip⦈)}"
proof(cases "∀ is ∈ set i_matches. (case is of Pos i ⇒ match_iface i (iface_sel iface)
| Neg i ⇒ ¬match_iface i (iface_sel iface))")
case False
have "get_all_matching_src_ips iface m = {}"
unfolding get_all_matching_src_ips_def
using select1 False by auto
with a show ?thesis by simp
next
case True
let ?γ="(common_matcher, in_doubt_allow) :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
let ?p="λp::('i, 'a) tagged_packet_scheme. p⦇p_iiface := iface_sel iface, p_src := ip⦈"
obtain ip_matches rest2 where select2: "primitive_extractor (is_Src, src_sel) rest1 = (ip_matches, rest2)" by fastforce
let ?noDisc="¬ has_primitive rest2"
have get_all_matching_src_ips_caseTrue: "get_all_matching_src_ips iface m =
(if ?noDisc ∧ matcheq_matchAny rest2
then if ip_matches = []
then UNIV
else ⋂((case_negation_type ipt_iprange_to_set (λip. - ipt_iprange_to_set ip) ` (set ip_matches)))
else {})"
unfolding get_all_matching_src_ips_def
by(simp add: True select1 select2)
from True have "(∀m∈set (getPos i_matches). matches ?γ (Match (IIface m)) a (?p p)) ∧
(∀m∈set (getNeg i_matches). matches ?γ (MatchNot (Match (IIface m))) a (?p p))"
for p :: "('i, 'a) tagged_packet_scheme"
by(simp add: negation_type_forall_split
primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
hence matches_iface: "matches ?γ (alist_and (NegPos_map IIface i_matches)) a (?p p)"
for p :: "('i,'a) tagged_packet_scheme"
by(simp add: matches_alist_and NegPos_map_simps)
show ?thesis
proof(cases "?noDisc ∧ matcheq_matchAny rest2")
case False
assume F: "¬ (?noDisc ∧ matcheq_matchAny rest2)"
with get_all_matching_src_ips_caseTrue have "get_all_matching_src_ips iface m = {}" by presburger
with a have False by simp
thus ?thesis ..
next
case True
assume F: "?noDisc ∧ matcheq_matchAny rest2"
with get_all_matching_src_ips_caseTrue have "get_all_matching_src_ips iface m =
(if ip_matches = []
then UNIV
else ⋂((case_negation_type ipt_iprange_to_set (λip. - ipt_iprange_to_set ip) ` (set ip_matches))))" by presburger
from primitive_extractor_correct[OF assms wf_disc_sel_common_primitive(5) select1] have
select1_matches: "matches ?γ (alist_and (NegPos_map IIface i_matches)) a p ∧ matches ?γ rest1 a p ⟷ matches ?γ m a p"
and normalized1: "normalized_nnf_match rest1" for p :: "('i,'a) tagged_packet_scheme"
apply -
apply fast+
done
from select1_matches matches_iface have
rest1_matches: "matches ?γ rest1 a (?p p) ⟷ matches ?γ m a (?p p)" for p :: "('i, 'a) tagged_packet_scheme" by blast
from primitive_extractor_correct[OF normalized1 wf_disc_sel_common_primitive(3) select2] have
select2_matches: "matches ?γ (alist_and (NegPos_map Src ip_matches)) a p ∧ matches ?γ rest2 a p ⟷
matches ?γ rest1 a p" for p :: "('i, 'a) tagged_packet_scheme"
by fast
with F matcheq_matchAny have "matches ?γ rest2 a p" for p :: "('i, 'a) tagged_packet_scheme" by metis
with select2_matches rest1_matches have ip_src_matches:
"matches ?γ (alist_and (NegPos_map Src ip_matches)) a (?p p) ⟷ matches ?γ m a (?p p)"
for p :: "('i, 'a) tagged_packet_scheme" by simp
have case_nil: "⋀p. ip_matches = [] ⟹ matches ?γ (alist_and (NegPos_map Src ip_matches)) a p"
by(simp add: bunch_of_lemmata_about_matches)
have case_list: "⋀p. ∀x∈set ip_matches. (case x of Pos i ⇒ ip ∈ ipt_iprange_to_set i
| Neg i ⇒ ip ∈ - ipt_iprange_to_set i) ⟹
matches ?γ (alist_and (NegPos_map Src ip_matches)) a (p⦇p_iiface := iface_sel iface, p_src := ip⦈)"
apply(simp add: matches_alist_and NegPos_map_simps)
apply(simp add: negation_type_forall_split match_simplematcher_SrcDst_not match_simplematcher_SrcDst)
done
from a show "ip ∈ {ip. ∀p :: ('i, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (p⦇p_iiface := iface_sel iface, p_src := ip⦈)}"
unfolding get_all_matching_src_ips_caseTrue
proof(clarsimp split: if_split_asm)
fix p :: "('i, 'a) tagged_packet_scheme"
assume "ip_matches = []"
with case_nil have "matches ?γ (alist_and (NegPos_map Src ip_matches)) a (?p p)" by simp
with ip_src_matches show "matches ?γ m a (?p p)" by simp
next
fix p :: "('i, 'a) tagged_packet_scheme"
assume "∀x∈set ip_matches. ip ∈ (case x of Pos x ⇒ ipt_iprange_to_set x | Neg ip ⇒ - ipt_iprange_to_set ip)"
hence "∀x∈set ip_matches. case x of Pos i ⇒ ip ∈ ipt_iprange_to_set i | Neg i ⇒ ip ∈ - ipt_iprange_to_set i"
by(simp_all split: negation_type.split negation_type.split_asm)
with case_list have "matches ?γ (alist_and (NegPos_map Src ip_matches)) a (?p p)" .
with ip_src_matches show "matches ?γ m a (?p p)" by simp
qed
qed
qed
qed
private definition get_exists_matching_src_ips_executable
:: "iface ⇒ 'i::len common_primitive match_expr ⇒ 'i wordinterval" where
"get_exists_matching_src_ips_executable iface m ≡ let (i_matches, _) = (primitive_extractor (is_Iiface, iiface_sel) m) in
if (∀ is ∈ set i_matches. (case is of Pos i ⇒ match_iface i (iface_sel iface)
| Neg i ⇒ ¬match_iface i (iface_sel iface)))
then
(let (ip_matches, _) = (primitive_extractor (is_Src, src_sel) m) in
if ip_matches = []
then
wordinterval_UNIV
else
l2wi_negation_type_intersect (NegPos_map ipt_iprange_to_interval ip_matches))
else
Empty_WordInterval"
lemma get_exists_matching_src_ips_executable:
"wordinterval_to_set (get_exists_matching_src_ips_executable iface m) = get_exists_matching_src_ips iface m"
apply(simp add: get_exists_matching_src_ips_executable_def get_exists_matching_src_ips_def)
apply(case_tac "primitive_extractor (is_Iiface, iiface_sel) m")
apply(case_tac "primitive_extractor (is_Src, src_sel) m")
apply(simp)
apply(simp add: l2wi_negation_type_intersect)
apply(simp add: NegPos_map_simps)
apply(safe)
apply(simp_all add: ipt_iprange_to_interval)
apply(rename_tac i_matches rest1 a b x xa)
apply(case_tac xa)
apply(simp_all add: NegPos_set)
using ipt_iprange_to_interval apply fast+
apply(rename_tac i_matches rest1 a b x aa ab ba)
apply(erule_tac x="Pos aa" in ballE)
apply(simp_all add: NegPos_set)
using NegPos_set(2) by fastforce
lemma "(get_exists_matching_src_ips_executable (Iface ''eth0'')
(MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0''))))) =
RangeUnion (WordInterval 0 0xC0A7FFFF) (WordInterval 0xC0A80100 0xFFFFFFFF)" by eval
private definition get_all_matching_src_ips_executable
:: "iface ⇒ 'i::len common_primitive match_expr ⇒ 'i wordinterval" where
"get_all_matching_src_ips_executable iface m ≡ let (i_matches, rest1) = (primitive_extractor (is_Iiface, iiface_sel) m) in
if (∀ is ∈ set i_matches. (case is of Pos i ⇒ match_iface i (iface_sel iface)
| Neg i ⇒ ¬match_iface i (iface_sel iface)))
then
(let (ip_matches, rest2) = (primitive_extractor (is_Src, src_sel) rest1) in
if ¬ has_primitive rest2 ∧ matcheq_matchAny rest2
then
if ip_matches = []
then
wordinterval_UNIV
else
l2wi_negation_type_intersect (NegPos_map ipt_iprange_to_interval ip_matches)
else
Empty_WordInterval)
else
Empty_WordInterval"
lemma get_all_matching_src_ips_executable:
"wordinterval_to_set (get_all_matching_src_ips_executable iface m) = get_all_matching_src_ips iface m"
apply(simp add: get_all_matching_src_ips_executable_def get_all_matching_src_ips_def)
apply(case_tac "primitive_extractor (is_Iiface, iiface_sel) m")
apply(simp, rename_tac i_matches rest1)
apply(case_tac "primitive_extractor (is_Src, src_sel) rest1")
apply(simp)
apply(simp add: l2wi_negation_type_intersect)
apply(simp add: NegPos_map_simps)
apply(safe)
apply(simp_all add: ipt_iprange_to_interval)
apply(rename_tac i_matches rest1 a b x xa)
apply(case_tac xa)
apply(simp_all add: NegPos_set)
using ipt_iprange_to_interval apply fast+
apply(rename_tac i_matches rest1 a b x aa ab ba)
apply(erule_tac x="Pos aa" in ballE)
apply(simp_all add: NegPos_set)
apply(erule_tac x="Neg aa" in ballE)
apply(simp_all add: NegPos_set)
done
lemma "(get_all_matching_src_ips_executable (Iface ''eth0'')
(MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0''))))) =
RangeUnion (WordInterval 0 0xC0A7FFFF) (WordInterval 0xC0A80100 0xFFFFFFFF)" by eval
text‹The following algorithm sound but not complete.›
private fun no_spoofing_algorithm
:: "iface ⇒ 'i::len ipassignment ⇒ 'i common_primitive rule list ⇒ 'i word set ⇒ 'i word set ⇒ bool" where
"no_spoofing_algorithm iface ipassmt [] allowed denied1 ⟷
(allowed - denied1) ⊆ ipcidr_union_set (set (the (ipassmt iface)))" |
"no_spoofing_algorithm iface ipassmt ((Rule m Accept)#rs) allowed denied1 = no_spoofing_algorithm iface ipassmt rs
(allowed ∪ get_exists_matching_src_ips iface m) denied1" |
"no_spoofing_algorithm iface ipassmt ((Rule m Drop)#rs) allowed denied1 = no_spoofing_algorithm iface ipassmt rs
allowed (denied1 ∪ (get_all_matching_src_ips iface m - allowed))" |
"no_spoofing_algorithm _ _ _ _ _ = undefined"
private fun no_spoofing_algorithm_executable
:: "iface ⇒ (iface ⇀ ('i::len word × nat) list) ⇒ 'i common_primitive rule list
⇒ 'i wordinterval ⇒ 'i wordinterval ⇒ bool" where
"no_spoofing_algorithm_executable iface ipassmt [] allowed denied1 ⟷
wordinterval_subset (wordinterval_setminus allowed denied1) (l2wi (map ipcidr_to_interval (the (ipassmt iface))))" |
"no_spoofing_algorithm_executable iface ipassmt ((Rule m Accept)#rs) allowed denied1 = no_spoofing_algorithm_executable iface ipassmt rs
(wordinterval_union allowed (get_exists_matching_src_ips_executable iface m)) denied1" |
"no_spoofing_algorithm_executable iface ipassmt ((Rule m Drop)#rs) allowed denied1 = no_spoofing_algorithm_executable iface ipassmt rs
allowed (wordinterval_union denied1 (wordinterval_setminus (get_all_matching_src_ips_executable iface m) allowed))" |
"no_spoofing_algorithm_executable _ _ _ _ _ = undefined"
lemma no_spoofing_algorithm_executable: "no_spoofing_algorithm_executable iface ipassmt rs allowed denied ⟷
no_spoofing_algorithm iface ipassmt rs (wordinterval_to_set allowed) (wordinterval_to_set denied)"
proof(induction iface ipassmt rs allowed denied rule: no_spoofing_algorithm_executable.induct)
case (1 iface ipassmt allowed denied1)
have "(⋃a∈set (the (ipassmt iface)). case ipcidr_to_interval a of (x, xa) ⇒ {x..xa}) =
(⋃x∈set (the (ipassmt iface)). uncurry ipset_from_cidr x)"
by(simp add: ipcidr_to_interval_def uncurry_def ipset_from_cidr_ipcidr_to_interval)
with 1 show ?case by(simp add: ipcidr_union_set_uncurry l2wi)
next
case 2 thus ?case by(simp add: get_exists_matching_src_ips_executable get_all_matching_src_ips_executable)
next
case 3 thus ?case by(simp add: get_exists_matching_src_ips_executable get_all_matching_src_ips_executable)
qed(simp_all)
private definition "nospoof TYPE('pkt_ext) iface ipassmt rs = (∀p :: ('i::len,'pkt_ext) tagged_packet_scheme.
(approximating_bigstep_fun (common_matcher, in_doubt_allow) (p⦇p_iiface:=iface_sel iface⦈) rs Undecided = Decision FinalAllow) ⟶
p_src p ∈ (ipcidr_union_set (set (the (ipassmt iface)))))"
private definition "setbydecision TYPE('pkt_ext) iface rs dec = {ip. ∃p :: ('i::len,'pkt_ext) tagged_packet_scheme. approximating_bigstep_fun (common_matcher, in_doubt_allow)
(p⦇p_iiface:=iface_sel iface, p_src := ip⦈) rs Undecided = Decision dec}"
private lemma nospoof_setbydecision:
fixes rs :: "'i::len common_primitive rule list"
shows "nospoof TYPE('pkt_ext) iface ipassmt rs ⟷
setbydecision TYPE('pkt_ext) iface rs FinalAllow ⊆ (ipcidr_union_set (set (the (ipassmt iface))))"
proof
assume a: "nospoof TYPE('pkt_ext) iface ipassmt rs"
have packet_update_iface_simp: "p⦇p_iiface := iface_sel iface, p_src := x⦈ = p⦇p_src := x, p_iiface := iface_sel iface⦈"
for p::"('i::len, 'p) tagged_packet_scheme" and x by simp
from a show "setbydecision TYPE('pkt_ext) iface rs FinalAllow ⊆ ipcidr_union_set (set (the (ipassmt iface)))"
apply(simp add: nospoof_def setbydecision_def)
apply(safe)
apply(rename_tac x p)
apply(erule_tac x="p⦇p_iiface := iface_sel iface, p_src := x⦈" in allE)
apply(simp)
apply(simp add: packet_update_iface_simp)
done
next
assume a1: "setbydecision TYPE('pkt_ext) iface rs FinalAllow ⊆ ipcidr_union_set (set (the (ipassmt iface)))"
show "nospoof TYPE('pkt_ext) iface ipassmt rs"
unfolding nospoof_def
proof(safe)
fix p :: "('i::len,'pkt_ext) tagged_packet_scheme"
assume a2: "approximating_bigstep_fun (common_matcher, in_doubt_allow) (p⦇p_iiface := iface_sel iface⦈) rs Undecided = Decision FinalAllow"
let ?setbydecision_fix_p="{ip. approximating_bigstep_fun (common_matcher, in_doubt_allow)
(p⦇p_iiface := iface_sel iface, p_src := ip⦈) rs Undecided = Decision FinalAllow}"
from a1 a2 have 1: "?setbydecision_fix_p ⊆ ipcidr_union_set (set (the (ipassmt iface)))" by(simp add: nospoof_def setbydecision_def) blast
from a2 have 2: "p_src p ∈ ?setbydecision_fix_p" by simp
from 1 2 show "p_src p ∈ ipcidr_union_set (set (the (ipassmt iface)))" by blast
qed
qed
private definition "setbydecision_all TYPE('pkt_ext) iface rs dec = {ip. ∀p :: ('i::len,'pkt_ext) tagged_packet_scheme.
approximating_bigstep_fun (common_matcher, in_doubt_allow) (p⦇p_iiface:=iface_sel iface, p_src := ip⦈) rs Undecided = Decision dec}"
private lemma setbydecision_setbydecision_all_Allow:
"(setbydecision TYPE('pkt_ext) iface rs FinalAllow - setbydecision_all TYPE('pkt_ext) iface rs FinalDeny) =
setbydecision TYPE('pkt_ext) iface rs FinalAllow"
apply(safe)
apply(simp add: setbydecision_def setbydecision_all_def)
done
private lemma setbydecision_setbydecision_all_Deny:
"(setbydecision TYPE('pkt_ext) iface rs FinalDeny - setbydecision_all TYPE('pkt_ext) iface rs FinalAllow) =
setbydecision TYPE('pkt_ext) iface rs FinalDeny"
apply(safe)
apply(simp add: setbydecision_def setbydecision_all_def)
done
private lemma setbydecision_append:
"simple_ruleset (rs1 @ rs2) ⟹
setbydecision TYPE('pkt_ext) iface (rs1 @ rs2) FinalAllow =
setbydecision TYPE('pkt_ext) iface rs1 FinalAllow ∪ {ip. ∃p :: ('i::len,'pkt_ext) tagged_packet_scheme. approximating_bigstep_fun (common_matcher, in_doubt_allow)
(p⦇p_iiface:=iface_sel iface, p_src := ip⦈) rs2 Undecided = Decision FinalAllow ∧
approximating_bigstep_fun (common_matcher, in_doubt_allow) (p⦇p_iiface:=iface_sel iface, p_src := ip⦈) rs1 Undecided = Undecided}"
apply(simp add: setbydecision_def)
apply(subst Set.Collect_disj_eq[symmetric])
apply(rule Set.Collect_cong)
apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
by blast
private lemma not_FinalAllow: "foo ≠ Decision FinalAllow ⟷ foo = Decision FinalDeny ∨ foo = Undecided"
apply(cases foo)
apply simp_all
apply(rename_tac x2)
apply(case_tac x2)
apply(simp_all)
done
private lemma setbydecision_all_appendAccept: "simple_ruleset (rs @ [Rule r Accept]) ⟹
setbydecision_all TYPE('pkt_ext) iface rs FinalDeny = setbydecision_all TYPE('pkt_ext) iface (rs @ [Rule r Accept]) FinalDeny"
apply(simp add: setbydecision_all_def)
apply(rule Set.Collect_cong)
apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
apply(simp add: not_FinalAllow)
done
private lemma setbydecision_all_append_subset: "simple_ruleset (rs1 @ rs2) ⟹
setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny ∪ {ip. ∀p :: ('i::len,'pkt_ext) tagged_packet_scheme.
approximating_bigstep_fun (common_matcher, in_doubt_allow) (p⦇p_iiface:=iface_sel iface, p_src := ip⦈) rs2 Undecided = Decision FinalDeny ∧
approximating_bigstep_fun (common_matcher, in_doubt_allow) (p⦇p_iiface:=iface_sel iface, p_src := ip⦈) rs1 Undecided = Undecided}
⊆
setbydecision_all TYPE('pkt_ext) iface (rs1 @ rs2) FinalDeny"
unfolding setbydecision_all_def
apply(subst Set.Collect_disj_eq[symmetric])
apply(rule Set.Collect_mono)
apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
apply(simp add: not_FinalAllow)
done
private lemma "setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny ∪
{ip. ∀p :: ('i::len,'pkt_ext) tagged_packet_scheme.
approximating_bigstep_fun (common_matcher, in_doubt_allow) (p⦇p_iiface := iface_sel iface, p_src := ip⦈) rs1 Undecided = Undecided}
⊆
- setbydecision TYPE('pkt_ext) iface rs1 FinalAllow"
unfolding setbydecision_all_def
unfolding setbydecision_def
apply(subst Set.Collect_neg_eq[symmetric])
apply(subst Set.Collect_disj_eq[symmetric])
apply(rule Set.Collect_mono)
by(simp)
private lemma Collect_minus_eq: "{x. P x} - {x. Q x} = {x. P x ∧ ¬ Q x}" by blast
private lemma setbydecision_all_append_subset2:
"simple_ruleset (rs1 @ rs2) ⟹
setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny ∪
(setbydecision_all TYPE('pkt_ext) iface rs2 FinalDeny -
setbydecision TYPE('pkt_ext) iface rs1 FinalAllow)
⊆ setbydecision_all TYPE('pkt_ext) iface (rs1 @ rs2) FinalDeny"
unfolding setbydecision_all_def
unfolding setbydecision_def
apply(subst Collect_minus_eq)
apply(subst Set.Collect_disj_eq[symmetric])
apply(rule Set.Collect_mono)
apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset; fail)
apply(intro impI allI)
apply(simp add: not_FinalAllow)
apply(case_tac "approximating_bigstep_fun (common_matcher, in_doubt_allow) (p⦇p_iiface := iface_sel iface, p_src := x⦈) rs1 Undecided")
subgoal by(elim disjE) simp_all
apply(rename_tac x2)
apply(case_tac x2)
prefer 2
apply simp
apply(elim disjE)
apply(simp)
by blast
private lemma "setbydecision_all TYPE('pkt_ext) iface rs FinalDeny ⊆ - setbydecision TYPE('pkt_ext) iface rs FinalAllow"
apply(simp add: setbydecision_def setbydecision_all_def)
apply(subst Set.Collect_neg_eq[symmetric])
apply(rule Set.Collect_mono)
apply(simp)
done
private lemma no_spoofing_algorithm_sound_generalized:
fixes rs1 :: "'i::len common_primitive rule list"
shows "simple_ruleset rs1 ⟹ simple_ruleset rs2 ⟹
(∀r ∈ set rs2. normalized_nnf_match (get_match r)) ⟹
setbydecision TYPE('pkt_ext) iface rs1 FinalAllow ⊆ allowed ⟹
denied1 ⊆ setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny ⟹
no_spoofing_algorithm iface ipassmt rs2 allowed denied1 ⟹
nospoof TYPE('pkt_ext) iface ipassmt (rs1@rs2)"
proof(induction iface ipassmt rs2 allowed denied1 arbitrary: rs1 allowed denied1 rule: no_spoofing_algorithm.induct)
case (1 iface ipassmt)
from 1 have "allowed - denied1 ⊆ ipcidr_union_set (set (the (ipassmt iface)))"
by(simp)
with 1 have "setbydecision TYPE('pkt_ext) iface rs1 FinalAllow - setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny
⊆ ipcidr_union_set (set (the (ipassmt iface)))"
by blast
thus ?case
by(simp add: nospoof_setbydecision setbydecision_setbydecision_all_Allow)
next
case (2 iface ipassmt m rs)
from 2(2) have simple_rs1: "simple_ruleset rs1" by(simp add: simple_ruleset_def)
hence simple_rs': "simple_ruleset (rs1 @ [Rule m Accept])" by(simp add: simple_ruleset_def)
from 2(3) have simple_rs: "simple_ruleset rs" by(simp add: simple_ruleset_def)
with 2 have IH: "⋀rs' allowed denied1.
simple_ruleset rs' ⟹
setbydecision TYPE('pkt_ext) iface rs' FinalAllow ⊆ allowed ⟹
denied1 ⊆ setbydecision_all TYPE('pkt_ext) iface rs' FinalDeny ⟹
no_spoofing_algorithm iface ipassmt rs allowed denied1 ⟹ nospoof TYPE('pkt_ext) iface ipassmt (rs' @ rs)"
by(simp)
from 2(5) have "setbydecision TYPE('pkt_ext) iface (rs1 @ [Rule m Accept]) FinalAllow ⊆
(allowed ∪ {ip. ∃p :: ('i::len,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Accept (p⦇p_iiface := iface_sel iface, p_src := ip⦈)})"
apply(simp add: setbydecision_append[OF simple_rs'])
by blast
with get_exists_matching_src_ips_subset 2(4) have allowed: "setbydecision TYPE('pkt_ext) iface (rs1 @ [Rule m Accept]) FinalAllow ⊆ (allowed ∪ get_exists_matching_src_ips iface m)"
by fastforce
from 2(6) setbydecision_all_appendAccept[OF simple_rs', where 'pkt_ext = 'pkt_ext] have denied1:
"denied1 ⊆ setbydecision_all TYPE('pkt_ext) iface (rs1 @ [Rule m Accept]) FinalDeny" by simp
from 2(7) have no_spoofing_algorithm_prems: "no_spoofing_algorithm iface ipassmt rs
(allowed ∪ get_exists_matching_src_ips iface m) denied1"
by(simp)
from IH[OF simple_rs' allowed denied1 no_spoofing_algorithm_prems] have "nospoof TYPE('pkt_ext) iface ipassmt ((rs1 @ [Rule m Accept]) @ rs)" by blast
thus ?case by(simp)
next
case (3 iface ipassmt m rs)
from 3(2) have simple_rs1: "simple_ruleset rs1" by(simp add: simple_ruleset_def)
hence simple_rs': "simple_ruleset (rs1 @ [Rule m Drop])" by(simp add: simple_ruleset_def)
from 3(3) have simple_rs: "simple_ruleset rs" by(simp add: simple_ruleset_def)
with 3 have IH: "⋀rs' allowed denied1.
simple_ruleset rs' ⟹
setbydecision TYPE('pkt_ext) iface rs' FinalAllow ⊆ allowed ⟹
denied1 ⊆ setbydecision_all TYPE('pkt_ext) iface rs' FinalDeny ⟹
no_spoofing_algorithm iface ipassmt rs allowed denied1 ⟹ nospoof TYPE('pkt_ext) iface ipassmt (rs' @ rs)"
by(simp)
from 3(5) simple_rs' have allowed: "setbydecision TYPE('pkt_ext) iface (rs1 @ [Rule m Drop]) FinalAllow ⊆ allowed "
by(simp add: setbydecision_append)
have "{ip. ∀p :: ('i,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Drop (p⦇p_iiface := iface_sel iface, p_src := ip⦈)} ⊆
setbydecision_all TYPE('pkt_ext) iface [Rule m Drop] FinalDeny" by(simp add: setbydecision_all_def)
with 3(5) have "setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny ∪ ({ip. ∀p :: ('i,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Drop (p⦇p_iiface := iface_sel iface, p_src := ip⦈)} - allowed) ⊆
setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny ∪ (setbydecision_all TYPE('pkt_ext) iface [Rule m Drop] FinalDeny - setbydecision TYPE('pkt_ext) iface rs1 FinalAllow)"
by blast
with 3(6) setbydecision_all_append_subset2[OF simple_rs', of iface] have
"denied1 ∪ ({ip. ∀p :: ('i,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Drop (p⦇p_iiface := iface_sel iface, p_src := ip⦈)} - allowed) ⊆
setbydecision_all TYPE('pkt_ext) iface (rs1 @ [Rule m Drop]) FinalDeny"
by blast
with get_all_matching_src_ips 3(4) have denied1:
"denied1 ∪ (get_all_matching_src_ips iface m - allowed) ⊆ setbydecision_all TYPE('pkt_ext) iface (rs1 @ [Rule m Drop]) FinalDeny"
by force
from 3(7) have no_spoofing_algorithm_prems: "no_spoofing_algorithm iface ipassmt rs allowed
(denied1 ∪ (get_all_matching_src_ips iface m - allowed))"
apply(simp)
done
from IH[OF simple_rs' allowed denied1 no_spoofing_algorithm_prems] have "nospoof TYPE('pkt_ext) iface ipassmt ((rs1 @ [Rule m Drop]) @ rs)" by blast
thus ?case by(simp)
next
case "4_1" thus ?case by(simp add: simple_ruleset_def)
next
case "4_2" thus ?case by(simp add: simple_ruleset_def)
next
case "4_3" thus ?case by(simp add: simple_ruleset_def)
next
case "4_4" thus ?case by(simp add: simple_ruleset_def)
next
case "4_5" thus ?case by(simp add: simple_ruleset_def)
next
case "4_6" thus ?case by(simp add: simple_ruleset_def)
next
case "4_7" thus ?case by(simp add: simple_ruleset_def)
qed
definition no_spoofing_iface :: "iface ⇒ 'i::len ipassignment ⇒ 'i common_primitive rule list ⇒ bool" where
"no_spoofing_iface iface ipassmt rs ≡ no_spoofing_algorithm iface ipassmt rs {} {}"
lemma[code]: "no_spoofing_iface iface ipassmt rs =
no_spoofing_algorithm_executable iface ipassmt rs Empty_WordInterval Empty_WordInterval"
by(simp add: no_spoofing_iface_def no_spoofing_algorithm_executable)
private corollary no_spoofing_algorithm_sound: "simple_ruleset rs ⟹ ∀r∈set rs. normalized_nnf_match (get_match r) ⟹
no_spoofing_iface iface ipassmt rs ⟹ nospoof TYPE('pkt_ext) iface ipassmt rs"
unfolding no_spoofing_iface_def
apply(rule no_spoofing_algorithm_sound_generalized[of "[]" rs iface "{}" "{}", simplified])
apply(simp_all)
apply(simp add: simple_ruleset_def)
apply(simp add: setbydecision_def)
done
text‹The @{const nospoof} definition used throughout the proofs corresponds to checking @{const no_spoofing} for all interfaces›
private lemma nospoof: "simple_ruleset rs ⟹ (∀iface ∈ dom ipassmt. nospoof TYPE('pkt_ext) iface ipassmt rs) ⟷ no_spoofing TYPE('pkt_ext) ipassmt rs"
unfolding nospoof_def no_spoofing_def
apply(drule simple_imp_good_ruleset)
apply(subst approximating_semantics_iff_fun_good_ruleset)
apply(simp_all)
done
theorem no_spoofing_iface: "simple_ruleset rs ⟹ ∀r∈set rs. normalized_nnf_match (get_match r) ⟹
∀iface ∈ dom ipassmt. no_spoofing_iface iface ipassmt rs ⟹ no_spoofing TYPE('pkt_ext) ipassmt rs"
by(auto dest: nospoof no_spoofing_algorithm_sound)
text‹Examples›
text‹Example 1:
Ruleset: Accept all non-spoofed packets, drop rest.
›
lemma "no_spoofing_iface
(Iface ''eth0'')
[Iface ''eth0'' ↦ [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
[Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (Iface ''eth0'')))) action.Accept,
Rule MatchAny action.Drop]" by eval
lemma "no_spoofing TYPE('pkt_ext)
[Iface ''eth0'' ↦ [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
[Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (Iface ''eth0'')))) action.Accept,
Rule MatchAny action.Drop]"
apply(rule no_spoofing_iface)
apply(simp_all add: simple_ruleset_def)
by eval
text‹Example 2:
Ruleset: Drop packets from a spoofed IP range, allow rest.
Handles negated interfaces correctly.
›
lemma "no_spoofing TYPE('pkt_ext)
[Iface ''eth0'' ↦ [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
[Rule (MatchAnd (Match (IIface (Iface ''wlan+''))) (Match (Extra ''no idea what this is''))) action.Accept,
Rule (MatchNot (Match (IIface (Iface ''eth0+'')))) action.Accept,
Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0'')))) action.Drop,
Rule MatchAny action.Accept]
"
apply(rule no_spoofing_iface)
apply(simp_all add: simple_ruleset_def)
by eval
text‹Example 3:
Accidentally, matching on wlan+, spoofed packets for eth0 are allowed.
First, we prove that there actually is no spoofing protection. Then we show that our algorithm finds out.
›
lemma "¬ no_spoofing TYPE('pkt_ext)
[Iface ''eth0'' ↦ [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
[Rule (MatchNot (Match (IIface (Iface ''wlan+'')))) action.Accept,
Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0'')))) action.Drop,
Rule MatchAny action.Accept]
"
apply(simp add: no_spoofing_def)
apply(rule_tac x="p⦇p_src := 0⦈" in exI)
apply(simp add: range_0_max_UNIV ipcidr_union_set_def)
apply(intro conjI)
apply(subst approximating_semantics_iff_fun_good_ruleset)
apply(simp add: good_ruleset_def; fail)
apply(simp add: bunch_of_lemmata_about_matches
match_simplematcher_SrcDst_not
primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
apply(intro impI, thin_tac _)
apply eval
apply eval
done
lemma "¬ no_spoofing_iface
(Iface ''eth0'')
[Iface ''eth0'' ↦ [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
[Rule (MatchNot (Match (IIface (Iface ''wlan+'')))) action.Accept,
Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0'')))) action.Drop,
Rule MatchAny action.Accept]
" by eval
text‹Example 4:
Ruleset: Drop packets coming from the wrong interface, allow the rest.
Warning: this does not prevent spoofing for eth0!
Explanation: someone on eth0 can send a packet e.g. with source IP 8.8.8.8
The ruleset only prevents spoofing of 192.168.0.0/24 for other interfaces
›
lemma "¬ no_spoofing TYPE('pkt_ext) [Iface ''eth0'' ↦ [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
[Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (MatchNot (Match (IIface (Iface ''eth0''))))) action.Drop,
Rule MatchAny action.Accept]"
apply(simp add: no_spoofing_def)
apply(rule_tac x="p⦇p_src := 0⦈" in exI)
apply(simp add: range_0_max_UNIV ipcidr_union_set_def)
apply(intro conjI)
apply(subst approximating_semantics_iff_fun_good_ruleset)
apply(simp add: good_ruleset_def; fail)
apply(simp add: bunch_of_lemmata_about_matches
primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
apply(intro impI, thin_tac _)
apply eval
apply eval
done
text‹Our algorithm detects it.›
lemma "¬ no_spoofing_iface
(Iface ''eth0'')
[Iface ''eth0'' ↦ [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
[Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (MatchNot (Match (IIface (Iface ''eth0''))))) action.Drop,
Rule MatchAny action.Accept]" by eval
text‹Example 5:
Spoofing protection but the algorithm fails.
The algorithm @{const no_spoofing_iface} is only sound, not complete.
The ruleset first drops spoofed packets for TCP and then drops spoofed packets for ‹¬ TCP›.
The algorithm cannot detect that ‹TCP ∪ ¬TCP› together will match all spoofed packets.›
lemma "no_spoofing TYPE('pkt_ext) [Iface ''eth0'' ↦ [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
[Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
(MatchAnd (Match (IIface (Iface ''eth0'')))
(Match (Prot (Proto TCP))))) action.Drop,
Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
(MatchAnd (Match (IIface (Iface ''eth0'')))
(MatchNot (Match (Prot (Proto TCP)))))) action.Drop,
Rule MatchAny action.Accept]" (is "no_spoofing TYPE('pkt_ext) ?ipassmt ?rs")
proof -
have 1: "∀p. (common_matcher, in_doubt_allow),p⊢ ⟨?rs, Undecided⟩ ⇒⇩α Decision FinalAllow ⟷
approximating_bigstep_fun (common_matcher, in_doubt_allow) p ?rs Undecided = Decision FinalAllow"
by(subst approximating_semantics_iff_fun_good_ruleset) (simp_all add: good_ruleset_def)
show ?thesis
unfolding no_spoofing_def
apply(simp add: 1 ipcidr_union_set_def)
apply(simp add: bunch_of_lemmata_about_matches
primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
apply(simp add: match_iface.simps match_simplematcher_SrcDst_not
primitive_matcher_generic.Prot_single[OF primitive_matcher_generic_common_matcher]
primitive_matcher_generic.Prot_single_not[OF primitive_matcher_generic_common_matcher])
done
qed
text‹Spoofing protection but the algorithm cannot certify spoofing protection.›
lemma "¬ no_spoofing_iface
(Iface ''eth0'')
[Iface ''eth0'' ↦ [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
[Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
(MatchAnd (Match (IIface (Iface ''eth0'')))
(Match (Prot (Proto TCP))))) action.Drop,
Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
(MatchAnd (Match (IIface (Iface ''eth0'')))
(MatchNot (Match (Prot (Proto TCP)))))) action.Drop,
Rule MatchAny action.Accept]" by eval
end
lemma "no_spoofing_iface (Iface ''eth1.1011'')
([Iface ''eth1.1011'' ↦ [(ipv4addr_of_dotdecimal (131,159,14,0), 24)]]:: 32 ipassignment)
[Rule (MatchNot (Match (IIface (Iface ''eth1.1011+'')))) action.Accept,
Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (131,159,14,0)) 24)))) (Match (IIface (Iface ''eth1.1011'')))) action.Drop,
Rule MatchAny action.Accept]" by eval
text‹We only check accepted packets.
If there is no default rule (this will never happen if parsed from iptables!), the result is unfinished.›
lemma "no_spoofing_iface (Iface ''eth1.1011'')
([Iface ''eth1.1011'' ↦ [(ipv4addr_of_dotdecimal (131,159,14,0), 24)]]:: 32 ipassignment)
[Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8))) Drop]" by eval
end
Theory Common_Primitive_toString
theory Common_Primitive_toString
imports Simple_Firewall.Primitives_toString
Common_Primitive_Matcher
begin
section‹Firewall toString Functions›
fun ipt_ipv4range_toString :: "32 ipt_iprange ⇒ string" where
"ipt_ipv4range_toString (IpAddr ip) = ipv4addr_toString ip" |
"ipt_ipv4range_toString (IpAddrNetmask ip n) = ipv4addr_toString ip@''/''@string_of_nat n" |
"ipt_ipv4range_toString (IpAddrRange ip1 ip2) = ipv4addr_toString ip1@''-''@ipv4addr_toString ip2"
fun ipt_ipv6range_toString :: "128 ipt_iprange ⇒ string" where
"ipt_ipv6range_toString (IpAddr ip) = ipv6addr_toString ip" |
"ipt_ipv6range_toString (IpAddrNetmask ip n) = ipv6addr_toString ip@''/''@string_of_nat n" |
"ipt_ipv6range_toString (IpAddrRange ip1 ip2) = ipv6addr_toString ip1@''-''@ipv6addr_toString ip2"
definition ipv4addr_wordinterval_pretty_toString :: "32 wordinterval ⇒ string" where
"ipv4addr_wordinterval_pretty_toString wi = list_toString ipt_ipv4range_toString (wi_to_ipt_iprange wi)"
lemma "ipv4addr_wordinterval_pretty_toString
(RangeUnion (RangeUnion (WordInterval 0x7F000000 0x7FFFFFFF) (WordInterval 0x1020304 0x1020306))
(WordInterval 0x8080808 0x8080808)) = ''[127.0.0.0/8, 1.2.3.4-1.2.3.6, 8.8.8.8]''" by eval
fun action_toString :: "action ⇒ string" where
"action_toString action.Accept = ''-j ACCEPT''" |
"action_toString action.Drop = ''-j DROP''" |
"action_toString action.Reject = ''-j REJECT''" |
"action_toString (action.Call target) = ''-j ''@target@'' (call)''" |
"action_toString (action.Goto target) = ''-g ''@target" |
"action_toString action.Empty = ''''" |
"action_toString action.Log = ''-j LOG''" |
"action_toString action.Return = ''-j RETURN''" |
"action_toString action.Unknown = ''!!!!!!!!!!! UNKNOWN !!!!!!!!!!!''"
fun common_primitive_toString :: "('i::len word ⇒ string) ⇒ 'i common_primitive ⇒ string" where
"common_primitive_toString ipToStr (Src (IpAddr ip)) = ''-s ''@ipToStr ip" |
"common_primitive_toString ipToStr (Dst (IpAddr ip)) = ''-d ''@ipToStr ip" |
"common_primitive_toString ipToStr (Src (IpAddrNetmask ip n)) = ''-s ''@ipToStr ip@''/''@string_of_nat n" |
"common_primitive_toString ipToStr (Dst (IpAddrNetmask ip n)) = ''-d ''@ipToStr ip@''/''@string_of_nat n" |
"common_primitive_toString ipToStr (Src (IpAddrRange ip1 ip2)) = ''-m iprange --src-range ''@ipToStr ip1@''-''@ipToStr ip2" |
"common_primitive_toString ipToStr (Dst (IpAddrRange ip1 ip2)) = ''-m iprange --dst-range ''@ipToStr ip1@''-''@ipToStr ip2" |
"common_primitive_toString _ (IIface ifce) = iface_toString ''-i '' ifce" |
"common_primitive_toString _ (OIface ifce) = iface_toString ''-o '' ifce" |
"common_primitive_toString _ (Prot prot) = ''-p ''@protocol_toString prot" |
"common_primitive_toString _ (Src_Ports (L4Ports prot pts)) = ''-m ''@primitive_protocol_toString prot@'' --spts '' @ list_toString (ports_toString '''') pts" |
"common_primitive_toString _ (Dst_Ports (L4Ports prot pts)) = ''-m ''@primitive_protocol_toString prot@'' --dpts '' @ list_toString (ports_toString '''') pts" |
"common_primitive_toString _ (MultiportPorts (L4Ports prot pts)) = ''-p ''@primitive_protocol_toString prot@'' -m multiport --ports '' @ list_toString (ports_toString '''') pts" |
"common_primitive_toString _ (CT_State S) = ''-m state --state ''@ctstate_set_toString S" |
"common_primitive_toString _ (L4_Flags (TCP_Flags c m)) = ''--tcp-flags ''@ipt_tcp_flags_toString c@'' ''@ipt_tcp_flags_toString m" |
"common_primitive_toString _ (Extra e) = ''~~''@e@''~~''"
definition common_primitive_ipv4_toString :: "32 common_primitive ⇒ string" where
"common_primitive_ipv4_toString ≡ common_primitive_toString ipv4addr_toString"
definition common_primitive_ipv6_toString :: "128 common_primitive ⇒ string" where
"common_primitive_ipv6_toString ≡ common_primitive_toString ipv6addr_toString"
fun common_primitive_match_expr_toString
:: "('i common_primitive ⇒ string) ⇒ 'i common_primitive match_expr ⇒ string" where
"common_primitive_match_expr_toString toStr MatchAny = ''''" |
"common_primitive_match_expr_toString toStr (Match m) = toStr m" |
"common_primitive_match_expr_toString toStr (MatchAnd m1 m2) =
common_primitive_match_expr_toString toStr m1 @'' '' @ common_primitive_match_expr_toString toStr m2" |
"common_primitive_match_expr_toString toStr (MatchNot (Match m)) = ''! ''@toStr m" |
"common_primitive_match_expr_toString toStr (MatchNot m) = ''NOT (''@common_primitive_match_expr_toString toStr m@'')''"
definition common_primitive_match_expr_ipv4_toString :: "32 common_primitive match_expr ⇒ string" where
"common_primitive_match_expr_ipv4_toString ≡ common_primitive_match_expr_toString common_primitive_ipv4_toString"
definition common_primitive_match_expr_ipv6_toString :: "128 common_primitive match_expr ⇒ string" where
"common_primitive_match_expr_ipv6_toString ≡ common_primitive_match_expr_toString common_primitive_ipv6_toString"
fun common_primitive_rule_toString :: "32 common_primitive rule ⇒ string" where
"common_primitive_rule_toString (Rule m a) = common_primitive_match_expr_ipv4_toString m @'' ''@action_toString a"
end
Theory Routing_IpAssmt
section‹Routing and IP Assignments›
theory Routing_IpAssmt
imports Ipassmt
Routing.Routing_Table
begin
context
begin
subsection‹Routing IP Assignment›
text‹Up to now, the definitions were all still on word intervals because those are much more convenient to work with.›
definition routing_ipassmt :: "'i::len routing_rule list ⇒ (iface × ('i word × nat) list) list"
where
"routing_ipassmt rt ≡ map (apfst Iface ∘ apsnd cidr_split) (routing_ipassmt_wi rt)"
private lemma ipcidr_union_cidr_split[simp]: "ipcidr_union_set (set (cidr_split x)) = wordinterval_to_set x"
apply(subst cidr_split_prefix[symmetric])
apply(fact ipcidr_union_set_uncurry)
done
private lemma map_of_map_Iface: "map_of (map (λx. (Iface (fst x), f (snd x))) xs) (Iface ifce) =
map_option f ((map_of xs) ifce)"
by (induct xs) (auto)
lemma "routing_ipassmt_wi ([]::32 prefix_routing) = [(output_iface (routing_action (undefined :: 32 routing_rule)), WordInterval 0 0xFFFFFFFF)]"
by code_simp
lemma routing_ipassmt: "
valid_prefixes rt ⟹
output_iface (routing_table_semantics rt (p_dst p)) = p_oiface p ⟹
∃p_ips. map_of (routing_ipassmt rt) (Iface (p_oiface p)) = Some p_ips ∧ p_dst p ∈ ipcidr_union_set (set p_ips)"
apply(simp add: routing_ipassmt_def)
apply(drule routing_ipassmt_wi[where output_port="p_oiface p" and k="p_dst p"])
apply(simp)
apply(elim exE, rename_tac ip_range)
apply(rule_tac x="cidr_split ip_range" in exI)
apply(simp)
apply(simp add: comp_def)
apply(simp add: map_of_map_Iface)
apply(rule_tac x="ip_range" in exI)
apply(simp)
by (simp add: routing_ipassmt_wi_distinct)
lemma routing_ipassmt_ipassmt_sanity_disjoint: "valid_prefixes (rt::('i::len) prefix_routing) ⟹
ipassmt_sanity_disjoint (map_of (routing_ipassmt rt))"
unfolding ipassmt_sanity_disjoint_def routing_ipassmt_def comp_def
apply(clarsimp)
apply(drule map_of_SomeD)+
apply(clarsimp split: iface.splits)
using routing_ipassmt_wi_disjoint[where 'i = 'i] by meson
lemma routing_ipassmt_distinct: "distinct (map fst (routing_ipassmt rtbl))"
using routing_ipassmt_wi_distinct[of rtbl]
unfolding routing_ipassmt_def
apply(simp add: comp_def)
apply(subst distinct_map[where f = Iface and xs = "map fst (routing_ipassmt_wi rtbl)", simplified, unfolded comp_def])
apply(auto intro: inj_onI)
done
end
end
Theory Output_Interface_Replace
theory Output_Interface_Replace
imports
Ipassmt
Routing_IpAssmt
Common_Primitive_toString
begin
section‹Replacing output interfaces by their IP ranges according to Routing›
text‹Copy of @{file ‹Interface_Replace.thy›}›
definition ipassmt_iface_replace_dstip_mexpr
:: "'i::len ipassignment ⇒ iface ⇒ 'i common_primitive match_expr" where
"ipassmt_iface_replace_dstip_mexpr ipassmt ifce ≡ case ipassmt ifce of
None ⇒ Match (OIface ifce)
| Some ips ⇒ (match_list_to_match_expr (map (Match ∘ Dst) (map (uncurry IpAddrNetmask) ips)))"
lemma matches_ipassmt_iface_replace_dstip_mexpr:
"matches (common_matcher, α) (ipassmt_iface_replace_dstip_mexpr ipassmt ifce) a p ⟷ (case ipassmt ifce of
None ⇒ match_iface ifce (p_oiface p)
| Some ips ⇒ p_dst p ∈ ipcidr_union_set (set ips)
)"
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: ipassmt_iface_replace_dstip_mexpr_def primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
next
case (Some ips)
have "matches (common_matcher, α) (match_list_to_match_expr (map (Match ∘ Dst ∘ (uncurry IpAddrNetmask)) ips)) a p ⟷
(∃m∈set ips. p_dst p ∈ (uncurry ipset_from_cidr m))"
by(simp add: match_list_to_match_expr_disjunction[symmetric]
match_list_matches match_simplematcher_SrcDst ipt_iprange_to_set_uncurry_IpAddrNetmask)
with Some show ?thesis
by(simp add: ipassmt_iface_replace_dstip_mexpr_def bunch_of_lemmata_about_matches ipcidr_union_set_uncurry)
qed
fun oiface_rewrite
:: "'i::len ipassignment ⇒ 'i common_primitive match_expr ⇒ 'i common_primitive match_expr"
where
"oiface_rewrite _ MatchAny = MatchAny" |
"oiface_rewrite ipassmt (Match (OIface ifce)) = ipassmt_iface_replace_dstip_mexpr ipassmt ifce" |
"oiface_rewrite _ (Match a) = Match a" |
"oiface_rewrite ipassmt (MatchNot m) = MatchNot (oiface_rewrite ipassmt m)" |
"oiface_rewrite ipassmt (MatchAnd m1 m2) = MatchAnd (oiface_rewrite ipassmt m1) (oiface_rewrite ipassmt m2)"
context
begin
private lemma oiface_rewrite_matches_Primitive:
"matches (common_matcher, α) (MatchNot (oiface_rewrite ipassmt (Match x))) a p = matches (common_matcher, α) (MatchNot (Match x)) a p ⟷
matches (common_matcher, α) (oiface_rewrite ipassmt (Match x)) a p = matches (common_matcher, α) (Match x) a p"
proof(cases x)
case (OIface ifce)
have "(matches (common_matcher, α) (MatchNot (ipassmt_iface_replace_dstip_mexpr ipassmt ifce)) a p = (¬ match_iface ifce (p_oiface p))) ⟷
(matches (common_matcher, α) (ipassmt_iface_replace_dstip_mexpr ipassmt ifce) a p = match_iface ifce (p_oiface p))"
proof(cases "ipassmt ifce")
case None thus ?thesis
apply(simp add: matches_ipassmt_iface_replace_dstip_mexpr)
apply(simp add: ipassmt_iface_replace_dstip_mexpr_def primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
done
next
case (Some ips)
{ fix ips
have "matches (common_matcher, α)
(MatchNot (match_list_to_match_expr (map (Match ∘ Dst ∘ (uncurry IpAddrNetmask)) ips))) a p ⟷
(p_dst p ∉ ipcidr_union_set (set ips))"
apply(induction ips)
apply(simp add: bunch_of_lemmata_about_matches ipcidr_union_set_uncurry)
apply(simp add: MatchOr_MatchNot)
apply(simp add: ipcidr_union_set_uncurry)
apply(simp add: match_simplematcher_SrcDst_not)
apply(thin_tac _)
apply(simp add: ipt_iprange_to_set_uncurry_IpAddrNetmask)
done
} note helper=this
from Some show ?thesis
apply(simp add: matches_ipassmt_iface_replace_dstip_mexpr)
apply(simp add: ipassmt_iface_replace_dstip_mexpr_def)
apply(simp add: helper)
done
qed
with OIface show ?thesis
by(simp add: primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher]
primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
qed(simp_all)
lemma ipassmt_disjoint_matcheq_iifce_dstip:
assumes ipassmt_nowild: "ipassmt_sanity_nowildcards ipassmt"
and ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
and ifce: "ipassmt ifce = Some i_ips"
and p_ifce: "ipassmt (Iface (p_oiface p)) = Some p_ips ∧ p_dst p ∈ ipcidr_union_set (set p_ips)"
shows "match_iface ifce (p_oiface p) ⟷ p_dst p ∈ ipcidr_union_set (set i_ips)"
proof
assume "match_iface ifce (p_oiface p)"
thus "p_dst p ∈ ipcidr_union_set (set i_ips)"
apply(cases "ifce = Iface (p_oiface p)")
using ifce p_ifce apply force
by (metis domI iface.sel iface_is_wildcard_def ifce ipassmt_nowild ipassmt_sanity_nowildcards_def match_iface.elims(2) match_iface_case_nowildcard)
next
assume a: "p_dst p ∈ ipcidr_union_set (set i_ips)"
from ipassmt_disjoint_nonempty_inj[OF ipassmt_disjoint ifce] a have ipassmt_inj: "∀k. ipassmt k = Some i_ips ⟶ k = ifce" by blast
from ipassmt_disjoint_inj_k[OF ipassmt_disjoint ifce _ a] have ipassmt_inj_k:
"⋀k ips'. ipassmt k = Some ips' ⟹ p_dst p ∈ ipcidr_union_set (set ips') ⟹ k = ifce" by simp
have ipassmt_inj_p: "∀ips'. p_dst p ∈ ipcidr_union_set (set ips') ∧ (∃k. ipassmt k = Some ips') ⟶ ips' = i_ips"
proof(intro allI impI; elim conjE exE)
fix ips' k
assume as: "p_dst p ∈ ipcidr_union_set (set ips')" "ipassmt k = Some ips'"
hence "k = ifce" using ipassmt_inj_k by simp
thus "ips' = i_ips" using ifce as by simp
qed
from p_ifce have "(Iface (p_oiface p)) = ifce" using ipassmt_inj_p ipassmt_inj by blast
thus "match_iface ifce (p_oiface p)" using match_iface_refl by blast
qed
private lemma matches_ipassmt_iface_replace_dstip_mexpr_case_Iface:
fixes ifce::iface
assumes "ipassmt_sanity_nowildcards ipassmt"
and "ipassmt_sanity_disjoint ipassmt"
and "ipassmt (Iface (p_oiface p)) = Some p_ips ∧ p_dst p ∈ ipcidr_union_set (set p_ips)"
shows "matches (common_matcher, α) (ipassmt_iface_replace_dstip_mexpr ipassmt ifce) a p ⟷
matches (common_matcher, α) (Match (OIface ifce)) a p"
proof -
have "matches (common_matcher, α) (ipassmt_iface_replace_dstip_mexpr ipassmt ifce) a p = match_iface ifce (p_oiface p)"
proof -
show ?thesis
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: matches_ipassmt_iface_replace_dstip_mexpr)
next
case (Some y) with assms(2) have "p_dst p ∈ ipcidr_union_set (set y) = match_iface ifce (p_oiface p)"
using assms(1) assms(3) ipassmt_disjoint_matcheq_iifce_dstip by blast
with Some show ?thesis by(simp add: matches_ipassmt_iface_replace_dstip_mexpr)
qed
qed
thus ?thesis by(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
qed
lemma matches_oiface_rewrite_ipassmt:
"normalized_nnf_match m ⟹ ipassmt_sanity_nowildcards ipassmt ⟹ ipassmt_sanity_disjoint ipassmt ⟹
(∃p_ips. ipassmt (Iface (p_oiface p)) = Some p_ips ∧ p_dst p ∈ ipcidr_union_set (set p_ips)) ⟹
matches (common_matcher, α) (oiface_rewrite ipassmt m) a p ⟷ matches (common_matcher, α) m a p"
proof(induction m)
case MatchAny thus ?case by simp
next
case (MatchNot m)
hence IH: "normalized_nnf_match m ⟹
matches (common_matcher, α) (oiface_rewrite ipassmt m) a p =matches (common_matcher, α) m a p" by blast
with MatchNot.prems IH show ?case by(induction m) (simp_all add: oiface_rewrite_matches_Primitive)
next
case(Match x) thus ?case
proof(cases x)
case (OIface ifce) with Match show ?thesis
apply(cases "ipassmt (Iface (p_oiface p))")
prefer 2
apply(simp add: matches_ipassmt_iface_replace_dstip_mexpr_case_Iface; fail)
by auto
qed(simp_all)
next
case (MatchAnd m1 m2) thus ?case by(simp add: bunch_of_lemmata_about_matches)
qed
lemma matches_oiface_rewrite:
"normalized_nnf_match m ⟹ ipassmt_sanity_nowildcards ipassmt ⟹
correct_routing rt ⟹
ipassmt = map_of (routing_ipassmt rt) ⟹
output_iface (routing_table_semantics rt (p_dst p)) = p_oiface p ⟹
matches (common_matcher, α) (oiface_rewrite ipassmt m) a p ⟷ matches (common_matcher, α) m a p"
apply(rule matches_oiface_rewrite_ipassmt; assumption?)
apply(simp add: correct_routing_def routing_ipassmt_ipassmt_sanity_disjoint; fail)
apply(simp)
apply(rule routing_ipassmt; assumption?)
apply(simp add: correct_routing_def; fail)
done
end
lemma oiface_rewrite_preserves_nodisc:
"∀a. ¬ disc (Dst a) ⟹ ¬ has_disc disc m ⟹ ¬ has_disc disc (oiface_rewrite ipassmt m)"
proof(induction ipassmt m rule: oiface_rewrite.induct)
case 2
have "∀a. ¬ disc (Dst a) ⟹ ¬ disc (OIface ifce) ⟹ ¬ has_disc disc (ipassmt_iface_replace_dstip_mexpr ipassmt ifce)"
for ifce ipassmt
apply(simp add: ipassmt_iface_replace_dstip_mexpr_def split: option.split)
apply(intro allI impI, rename_tac ips)
apply(drule_tac X=Dst and ls="map (uncurry IpAddrNetmask) ips" in match_list_to_match_expr_not_has_disc)
apply(simp)
done
with 2 show ?case by simp
qed(simp_all)
end
Theory Interface_Replace
theory Interface_Replace
imports
No_Spoof
Common_Primitive_toString
Output_Interface_Replace
begin
section‹Trying to connect inbound interfaces by their IP ranges›
subsection‹Constraining Interfaces›
text‹We keep the match on the interface but add the corresponding IP address range.›
definition ipassmt_iface_constrain_srcip_mexpr
:: "'i::len ipassignment ⇒ iface ⇒ 'i common_primitive match_expr"
where
"ipassmt_iface_constrain_srcip_mexpr ipassmt ifce = (case ipassmt ifce of
None ⇒ Match (IIface ifce)
| Some ips ⇒ MatchAnd
(Match (IIface ifce))
(match_list_to_match_expr (map (Match ∘ Src) (map (uncurry IpAddrNetmask) ips)))
)"
lemma matches_ipassmt_iface_constrain_srcip_mexpr:
"matches (common_matcher, α) (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce) a p ⟷
(case ipassmt ifce of
None ⇒ match_iface ifce (p_iiface p)
| Some ips ⇒ match_iface ifce (p_iiface p) ∧ p_src p ∈ ipcidr_union_set (set ips)
)"
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: ipassmt_iface_constrain_srcip_mexpr_def primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]; fail)
next
case (Some ips)
have "matches (common_matcher, α) (match_list_to_match_expr (map (Match ∘ Src ∘ (uncurry IpAddrNetmask)) ips)) a p ⟷
(∃m∈set ips. p_src p ∈ uncurry ipset_from_cidr m)"
apply(simp add: match_list_to_match_expr_disjunction[symmetric]
match_list_matches match_simplematcher_SrcDst)
by(simp add: ipt_iprange_to_set_uncurry_IpAddrNetmask)
with Some show ?thesis
apply(simp add: ipcidr_union_set_uncurry)
apply(simp add: ipassmt_iface_constrain_srcip_mexpr_def bunch_of_lemmata_about_matches)
apply(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
done
qed
fun iiface_constrain :: "'i::len ipassignment ⇒ 'i common_primitive match_expr ⇒ 'i common_primitive match_expr" where
"iiface_constrain _ MatchAny = MatchAny" |
"iiface_constrain ipassmt (Match (IIface ifce)) = ipassmt_iface_constrain_srcip_mexpr ipassmt ifce" |
"iiface_constrain ipassmt (Match a) = Match a" |
"iiface_constrain ipassmt (MatchNot m) = MatchNot (iiface_constrain ipassmt m)" |
"iiface_constrain ipassmt (MatchAnd m1 m2) = MatchAnd (iiface_constrain ipassmt m1) (iiface_constrain ipassmt m2)"
context
begin
private lemma iiface_constrain_matches_Primitive:
"matches (common_matcher, α) (MatchNot (iiface_constrain ipassmt (Match x))) a p = matches (common_matcher, α) (MatchNot (Match x)) a p ⟷
matches (common_matcher, α) (iiface_constrain ipassmt (Match x)) a p = matches (common_matcher, α) (Match x) a p"
proof(cases x)
case (IIface ifce)
have "(matches (common_matcher, α) (MatchNot (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce)) a p = (¬ match_iface ifce (p_iiface p))) ⟷
(matches (common_matcher, α) (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce) a p = match_iface ifce (p_iiface p))"
proof(cases "ipassmt ifce")
case None thus ?thesis
apply(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
apply(simp add: ipassmt_iface_constrain_srcip_mexpr_def
primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
done
next
case (Some ips)
{ fix ips
have "matches (common_matcher, α)
(MatchNot (match_list_to_match_expr (map (Match ∘ Src ∘ (uncurry IpAddrNetmask)) ips))) a p ⟷
(p_src p ∉ ipcidr_union_set (set ips))"
apply(induction ips)
apply(simp add: bunch_of_lemmata_about_matches ipcidr_union_set_uncurry; fail)
apply(simp add: MatchOr_MatchNot)
apply(simp add: ipcidr_union_set_uncurry)
apply(simp add: match_simplematcher_SrcDst_not)
apply(thin_tac _)
by (simp add: ipt_iprange_to_set_uncurry_IpAddrNetmask)
} note helper=this
from Some show ?thesis
apply(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
apply(simp add: ipassmt_iface_constrain_srcip_mexpr_def primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
apply(simp add: matches_DeMorgan)
apply(simp add: helper)
apply(simp add: primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
by blast
qed
with IIface show ?thesis
by(simp add: primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher]
primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
qed(simp_all)
private lemma matches_ipassmt_iface_constrain_srcip_mexpr_case_Iface:
fixes ifce::iface
assumes "ipassmt_sanity_nowildcards ipassmt"
and "⋀ips. ipassmt (Iface (p_iiface p)) = Some ips ⟹ p_src p ∈ ipcidr_union_set (set ips)"
shows "matches (common_matcher, α) (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce) a p ⟷
matches (common_matcher, α) (Match (IIface ifce)) a p"
proof -
have "matches (common_matcher, α) (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce) a p = match_iface ifce (p_iiface p)"
proof(cases "ipassmt (Iface (p_iiface p))")
case None
from None show ?thesis
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
next
case (Some a)
from assms(1) have "¬ match_iface ifce (p_iiface p)"
apply(rule ipassmt_sanity_nowildcards_match_iface)
by(simp_all add: Some None)
with Some show ?thesis by(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
qed
next
case (Some x)
with assms(2) have assms2: "p_src p ∈ ipcidr_union_set (set x)" by(simp)
show ?thesis
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
next
case (Some y) with assms(2) have "(match_iface ifce (p_iiface p) ∧ p_src p ∈ ipcidr_union_set (set y)) = match_iface ifce (p_iiface p)"
apply(cases ifce)
apply(rename_tac ifce_str)
apply(case_tac "ifce_str = (p_iiface p)")
apply (simp add: match_iface_refl; fail)
apply(simp)
apply(subgoal_tac "¬ match_iface (Iface ifce_str) (p_iiface p)")
apply(simp)
using assms(1) by (metis domI iface.sel iface_is_wildcard_def ipassmt_sanity_nowildcards_def match_iface_case_nowildcard)
with Some show ?thesis by(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
qed
qed
thus ?thesis by(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
qed
lemma matches_iiface_constrain:
"normalized_nnf_match m ⟹ ipassmt_sanity_nowildcards ipassmt ⟹
(⋀ips. ipassmt (Iface (p_iiface p)) = Some ips ⟹ p_src p ∈ ipcidr_union_set (set ips)) ⟹
matches (common_matcher, α) (iiface_constrain ipassmt m) a p ⟷ matches (common_matcher, α) m a p"
proof(induction m)
case MatchAny thus ?case by simp
next
case (MatchNot m)
hence IH: "normalized_nnf_match m ⟹ matches (common_matcher, α) (iiface_constrain ipassmt m) a p = matches (common_matcher, α) m a p" by blast
with MatchNot.prems IH show ?case by(induction m) (simp_all add: iiface_constrain_matches_Primitive)
next
case(Match x) thus ?case
proof(cases x)
case (IIface ifce) with Match show ?thesis
using matches_ipassmt_iface_constrain_srcip_mexpr_case_Iface by fastforce
qed(simp_all)
next
case (MatchAnd m1 m2) thus ?case by(simp add: bunch_of_lemmata_about_matches)
qed
end
subsection‹Sanity checking the assumption›
lemma "(∃ips. ipassmt (Iface (p_iiface p)) = Some ips ∧ p_src p ∈ ipcidr_union_set (set ips)) ⟹
(case ipassmt (Iface (p_iiface p)) of Some ips ⇒ p_src p ∈ ipcidr_union_set (set ips))"
"(case ipassmt (Iface (p_iiface p)) of Some ips ⇒ p_src p ∈ ipcidr_union_set (set ips)) ⟹
(⋀ips. ipassmt (Iface (p_iiface p)) = Some ips ⟹ p_src p ∈ ipcidr_union_set (set ips))"
by(cases "ipassmt (Iface (p_iiface p))",simp_all)+
text‹Sanity check:
If we assume that there are no spoofed packets, spoofing protection is trivially fulfilled.›
lemma "∀ p:: ('i::len,'pkt_ext) tagged_packet_scheme.
Iface (p_iiface p) ∈ dom ipassmt ⟶ p_src p ∈ ipcidr_union_set (set (the (ipassmt (Iface (p_iiface p))))) ⟹
no_spoofing TYPE('pkt_ext) ipassmt rs"
apply(simp add: no_spoofing_def)
apply(clarify)
apply(rename_tac iface ips p)
apply(thin_tac "_,_⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow")
apply(erule_tac x="p⦇p_iiface := iface_sel iface⦈" in allE)
apply(auto)
done
text‹Sanity check:
If the firewall features spoofing protection and we look at a packet which was allowed by the firewall.
Then the packet's src ip must be according to ipassmt. (case Some)
We don't case about packets from an interface which are not defined in ipassmt. (case None)›
lemma
fixes p :: "('i::len,'pkt_ext) tagged_packet_scheme"
shows "no_spoofing TYPE('pkt_ext) ipassmt rs ⟹
(common_matcher, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ⟹
case ipassmt (Iface (p_iiface p)) of Some ips ⇒ p_src p ∈ ipcidr_union_set (set ips) | None ⇒ True"
apply(simp add: no_spoofing_def)
apply(case_tac "Iface (p_iiface p) ∈ dom ipassmt")
apply(erule_tac x="Iface (p_iiface p)" in ballE)
apply(simp_all)
apply(erule_tac x="p" in allE)
apply(simp)
apply fastforce
by (simp add: domIff)
subsection‹Replacing Interfaces Completely›
text‹This is a stricter, true rewriting since it removes the interface match completely.
However, it requires @{const ipassmt_sanity_disjoint}›
thm ipassmt_sanity_disjoint_def
definition ipassmt_iface_replace_srcip_mexpr
:: "'i::len ipassignment ⇒ iface ⇒ 'i common_primitive match_expr" where
"ipassmt_iface_replace_srcip_mexpr ipassmt ifce ≡ case ipassmt ifce of
None ⇒ Match (IIface ifce)
| Some ips ⇒ (match_list_to_match_expr (map (Match ∘ Src) (map (uncurry IpAddrNetmask) ips)))"
lemma matches_ipassmt_iface_replace_srcip_mexpr:
"matches (common_matcher, α) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p ⟷ (case ipassmt ifce of
None ⇒ match_iface ifce (p_iiface p)
| Some ips ⇒ p_src p ∈ ipcidr_union_set (set ips)
)"
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: ipassmt_iface_replace_srcip_mexpr_def primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
next
case (Some ips)
have "matches (common_matcher, α) (match_list_to_match_expr (map (Match ∘ Src ∘ (uncurry IpAddrNetmask)) ips)) a p ⟷
(∃m∈set ips. p_src p ∈ (uncurry ipset_from_cidr m))"
by(simp add: match_list_to_match_expr_disjunction[symmetric]
match_list_matches match_simplematcher_SrcDst ipt_iprange_to_set_uncurry_IpAddrNetmask)
with Some show ?thesis
apply(simp add: ipassmt_iface_replace_srcip_mexpr_def bunch_of_lemmata_about_matches)
apply(simp add: ipcidr_union_set_uncurry)
done
qed
fun iiface_rewrite
:: "'i::len ipassignment ⇒ 'i common_primitive match_expr ⇒ 'i common_primitive match_expr"
where
"iiface_rewrite _ MatchAny = MatchAny" |
"iiface_rewrite ipassmt (Match (IIface ifce)) = ipassmt_iface_replace_srcip_mexpr ipassmt ifce" |
"iiface_rewrite ipassmt (Match a) = Match a" |
"iiface_rewrite ipassmt (MatchNot m) = MatchNot (iiface_rewrite ipassmt m)" |
"iiface_rewrite ipassmt (MatchAnd m1 m2) = MatchAnd (iiface_rewrite ipassmt m1) (iiface_rewrite ipassmt m2)"
context
begin
private lemma iiface_rewrite_matches_Primitive:
"matches (common_matcher, α) (MatchNot (iiface_rewrite ipassmt (Match x))) a p = matches (common_matcher, α) (MatchNot (Match x)) a p ⟷
matches (common_matcher, α) (iiface_rewrite ipassmt (Match x)) a p = matches (common_matcher, α) (Match x) a p"
proof(cases x)
case (IIface ifce)
have "(matches (common_matcher, α) (MatchNot (ipassmt_iface_replace_srcip_mexpr ipassmt ifce)) a p = (¬ match_iface ifce (p_iiface p))) ⟷
(matches (common_matcher, α) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p = match_iface ifce (p_iiface p))"
proof(cases "ipassmt ifce")
case None thus ?thesis
apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
apply(simp add: ipassmt_iface_replace_srcip_mexpr_def primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
done
next
case (Some ips)
{ fix ips
have "matches (common_matcher, α)
(MatchNot (match_list_to_match_expr (map (Match ∘ Src ∘ (uncurry IpAddrNetmask)) ips))) a p ⟷
(p_src p ∉ ipcidr_union_set (set ips))"
apply(induction ips)
apply(simp add: bunch_of_lemmata_about_matches ipcidr_union_set_uncurry)
apply(simp add: MatchOr_MatchNot)
apply(simp add: ipcidr_union_set_uncurry)
apply(simp add: match_simplematcher_SrcDst_not)
apply(thin_tac _)
apply(simp add: ipt_iprange_to_set_uncurry_IpAddrNetmask)
done
} note helper=this
from Some show ?thesis
apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
apply(simp add: ipassmt_iface_replace_srcip_mexpr_def)
apply(simp add: helper)
done
qed
with IIface show ?thesis
by(simp add: primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher]
primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
qed(simp_all)
private lemma matches_ipassmt_iface_replace_srcip_mexpr_case_Iface:
fixes ifce::iface
assumes "ipassmt_sanity_nowildcards ipassmt"
and "ipassmt_sanity_disjoint ipassmt"
and "ipassmt (Iface (p_iiface p)) = Some p_ips ∧ p_src p ∈ ipcidr_union_set (set p_ips)"
shows "matches (common_matcher, α) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p ⟷
matches (common_matcher, α) (Match (IIface ifce)) a p"
proof -
have "matches (common_matcher, α) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p = match_iface ifce (p_iiface p)"
proof -
show ?thesis
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
next
case (Some y) with assms(2) have "p_src p ∈ ipcidr_union_set (set y) = match_iface ifce (p_iiface p)"
using assms(1) assms(3) ipassmt_disjoint_matcheq_iifce_srcip by blast
with Some show ?thesis by(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
qed
qed
thus ?thesis by(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
qed
lemma matches_iiface_rewrite:
"normalized_nnf_match m ⟹ ipassmt_sanity_nowildcards ipassmt ⟹ ipassmt_sanity_disjoint ipassmt ⟹
(∃p_ips. ipassmt (Iface (p_iiface p)) = Some p_ips ∧ p_src p ∈ ipcidr_union_set (set p_ips)) ⟹
matches (common_matcher, α) (iiface_rewrite ipassmt m) a p ⟷ matches (common_matcher, α) m a p"
proof(induction m)
case MatchAny thus ?case by simp
next
case (MatchNot m)
hence IH: "normalized_nnf_match m ⟹
matches (common_matcher, α) (iiface_rewrite ipassmt m) a p =matches (common_matcher, α) m a p" by blast
with MatchNot.prems IH show ?case by(induction m) (simp_all add: iiface_rewrite_matches_Primitive)
next
case(Match x) thus ?case
proof(cases x)
case (IIface ifce) with Match show ?thesis
apply(cases "ipassmt (Iface (p_iiface p))")
prefer 2
apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr_case_Iface; fail)
by auto
qed(simp_all)
next
case (MatchAnd m1 m2) thus ?case by(simp add: bunch_of_lemmata_about_matches)
qed
end
text‹Finally, we show that @{const ipassmt_sanity_disjoint} is really needed.›
lemma iface_replace_needs_ipassmt_disjoint:
assumes "ipassmt_sanity_nowildcards ipassmt"
and iface_replace: "⋀ ifce p:: 'i::len tagged_packet.
(matches (common_matcher, α) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p ⟷ matches (common_matcher, α) (Match (IIface ifce)) a p)"
shows "ipassmt_sanity_disjoint ipassmt"
unfolding ipassmt_sanity_disjoint_def
proof(intro ballI impI)
fix i1 i2
assume "i1 ∈ dom ipassmt" and "i2 ∈ dom ipassmt" and "i1 ≠ i2"
from ‹i1 ∈ dom ipassmt› obtain i1_ips where i1_ips: "ipassmt i1 = Some i1_ips" by blast
from ‹i2 ∈ dom ipassmt› obtain i2_ips where i2_ips: "ipassmt i2 = Some i2_ips" by blast
{ fix p :: "'i tagged_packet"
from iface_replace[of i1 "p⦇ p_iiface := iface_sel i2⦈"] have
"(p_src p ∈ ipcidr_union_set (set i2_ips) ⟹ (p_src p ∈ ipcidr_union_set (set i1_ips)) = match_iface i1 (iface_sel i2))"
apply(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher] ‹i1 ∈ dom ipassmt›)
apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr i1_ips)
done
with ‹i1 ≠ i2› have "¬ (p_src p ∈ ipcidr_union_set (set i2_ips) ∧ (p_src p ∈ ipcidr_union_set (set i1_ips)))"
by (metis ‹i1 ∈ dom ipassmt› assms(1) iface.exhaust_sel iface_is_wildcard_def ipassmt_sanity_nowildcards_def match_iface_case_nowildcard)
}
hence "¬ (src ∈ ipcidr_union_set (set i2_ips) ∧ (src ∈ ipcidr_union_set (set i1_ips)))"
for src
apply(simp)
by (metis simple_packet.select_convs(3))
thus "ipcidr_union_set (set (the (ipassmt i1))) ∩ ipcidr_union_set (set (the (ipassmt i2))) = {}"
apply(simp add: i1_ips i2_ips)
by blast
qed
end
Theory Optimizing
theory Optimizing
imports Semantics_Ternary
begin
section‹Optimizing›
subsection‹Removing Shadowed Rules›
text‹Note: there is no executable code for rmshadow at the moment›
text‹Assumes: @{term "simple_ruleset"}›
fun rmshadow :: "('a, 'p) match_tac ⇒ 'a rule list ⇒ 'p set ⇒ 'a rule list" where
"rmshadow _ [] _ = []" |
"rmshadow γ ((Rule m a)#rs) P = (if (∀p∈P. ¬ matches γ m a p)
then
rmshadow γ rs P
else
(Rule m a) # (rmshadow γ rs {p ∈ P. ¬ matches γ m a p}))"
subsubsection‹Soundness›
lemma rmshadow_sound:
"simple_ruleset rs ⟹ p ∈ P ⟹ approximating_bigstep_fun γ p (rmshadow γ rs P) = approximating_bigstep_fun γ p rs"
proof(induction rs arbitrary: P)
case Nil thus ?case by simp
next
case (Cons r rs)
let ?fw="approximating_bigstep_fun γ"
let ?rm="rmshadow γ"
let ?match="matches γ (get_match r) (get_action r)"
let ?set="{p ∈ P. ¬ ?match p}"
from Cons.IH Cons.prems have IH: "?fw p (?rm rs P) = ?fw p rs" by (simp add: simple_ruleset_def)
from Cons.IH[of "?set"] Cons.prems have IH': "p ∈ ?set ⟹ ?fw p (?rm rs ?set) = ?fw p rs" by (simp add: simple_ruleset_def)
from Cons show ?case
proof(cases "∀p∈P. ¬ ?match p")
case True
from True have 1: "?rm (r#rs) P = ?rm rs P"
apply(cases r)
apply(rename_tac m a)
apply(clarify)
apply(simp)
done
from True Cons.prems have "?fw p (r # rs) = ?fw p rs"
apply(cases r)
apply(rename_tac m a)
apply(simp add: fun_eq_iff)
apply(clarify)
apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
apply(simp)
done
from this IH have "?fw p (?rm rs P) = ?fw p (r#rs) " by simp
thus "?fw p (?rm (r#rs) P) = ?fw p (r#rs) " using 1 by simp
next
case False
have "?fw p (r # (?rm rs ?set)) = ?fw p (r # rs)"
proof(cases "p ∈ ?set")
case True
from True IH' show "?fw p (r # (?rm rs ?set)) = ?fw p (r#rs)"
apply(cases r)
apply(rename_tac m a)
apply(simp add: fun_eq_iff)
apply(clarify)
apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
apply(simp)
done
next
case False
from False Cons.prems have "?match p" by simp
from Cons.prems have "get_action r = Accept ∨ get_action r = Drop" by(simp add: simple_ruleset_def)
from this ‹?match p›show "?fw p (r # (?rm rs ?set)) = ?fw p (r#rs)"
apply(cases r)
apply(rename_tac m a)
apply(simp add: fun_eq_iff)
apply(clarify)
apply(rename_tac s)
apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
apply(simp split:action.split)
apply fast
done
qed
from False this show ?thesis
apply(cases r)
apply(rename_tac m a)
apply(simp add: fun_eq_iff)
apply(clarify)
apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
apply(simp)
done
qed
qed
subsection‹Removing rules which cannot apply›
fun rmMatchFalse :: "'a rule list ⇒ 'a rule list" where
"rmMatchFalse [] = []" |
"rmMatchFalse ((Rule (MatchNot MatchAny) _)#rs) = rmMatchFalse rs" |
"rmMatchFalse (r#rs) = r # rmMatchFalse rs"
lemma rmMatchFalse_correct: "approximating_bigstep_fun γ p (rmMatchFalse rs) s = approximating_bigstep_fun γ p rs s"
proof-
{ fix m::"'a match_expr" and a and rs
assume assm: "m ≠ MatchNot MatchAny"
have "rmMatchFalse (Rule m a # rs) = Rule m a # (rmMatchFalse rs)" (is ?hlp)
proof(cases m)
case (MatchNot mexpr) with assm show ?hlp by(cases mexpr) simp_all
qed(simp_all)
} note rmMatchFalse_helper=this
show ?thesis
proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
case Empty thus ?case by(simp)
next
case Decision thus ?case by(metis Decision_approximating_bigstep_fun)
next
case (Nomatch γ p m a) thus ?case
by(cases "m = MatchNot MatchAny") (simp_all add: rmMatchFalse_helper)
next
case (Match γ p m a rs)
from Match(1) have "m ≠ MatchNot MatchAny" using bunch_of_lemmata_about_matches(3) by fast
with Match rmMatchFalse_helper show ?case by(simp split:action.split)
qed
qed
text‹We can stop after a default rule (a rule which matches anything) is observed.›
fun cut_off_after_match_any :: "'a rule list ⇒ 'a rule list" where
"cut_off_after_match_any [] = []" |
"cut_off_after_match_any (Rule m a # rs) =
(if m = MatchAny ∧ (a = Accept ∨ a = Drop ∨ a = Reject)
then [Rule m a] else Rule m a # cut_off_after_match_any rs)"
lemma cut_off_after_match_any:
"approximating_bigstep_fun γ p (cut_off_after_match_any rs) s = approximating_bigstep_fun γ p rs s"
apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
apply(induction γ p rs s rule: approximating_bigstep_fun.induct)
apply(simp; fail)
apply(simp; fail)
by(simp split: action.split action.split_asm add: bunch_of_lemmata_about_matches(2))
lemma cut_off_after_match_any_simplers: "simple_ruleset rs ⟹ simple_ruleset (cut_off_after_match_any rs)"
by(induction rs rule: cut_off_after_match_any.induct) (simp_all add: simple_ruleset_def)
lemma cut_off_after_match_any_preserve_matches:
"∀ r ∈ set rs. P (get_match r) ⟹ ∀ r ∈ set (cut_off_after_match_any rs). P (get_match r)"
apply(induction rs rule: cut_off_after_match_any.induct)
apply(simp; fail)
by(auto simp add: simple_ruleset_def)
end
Theory Transform
section‹Optimizing and Normalizing Primitives›
theory Transform
imports Common_Primitive_Lemmas
"../Semantics_Ternary/Semantics_Ternary"
"../Semantics_Ternary/Negation_Type_Matching"
Ports_Normalize
IpAddresses_Normalize
Interfaces_Normalize
Protocols_Normalize
"../Common/Remdups_Rev"
Interface_Replace
"../Semantics_Ternary/Optimizing"
begin
text‹This transform theory plugs a lot of stuff together. We perform several normalization and
optimization steps on complete firewall rulesets. We show that it preserves the semantics and also,
that structural properties are preserved. For example, if you normalize interfaces and afterwards
normalize protocols, the interfaces remain normalized and no new interfaces are added when
doing the protocol normalization.›
definition compress_normalize_besteffort
:: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr option" where
"compress_normalize_besteffort m ≡ compress_normalize_primitive_monad
[compress_normalize_protocols,
compress_normalize_input_interfaces,
compress_normalize_output_interfaces] m"
context begin
private lemma compress_normalize_besteffort_normalized:
"f ∈ set [compress_normalize_protocols,
compress_normalize_input_interfaces,
compress_normalize_output_interfaces] ⟹
normalized_nnf_match m ⟹ f m = Some m' ⟹ normalized_nnf_match m'"
apply(simp)
apply(elim disjE)
using compress_normalize_protocols_nnf apply blast
using compress_normalize_input_interfaces_nnf apply blast
using compress_normalize_output_interfaces_nnf apply blast
done
private lemma compress_normalize_besteffort_matches:
assumes generic: "primitive_matcher_generic β"
shows "f ∈ set [compress_normalize_protocols,
compress_normalize_input_interfaces,
compress_normalize_output_interfaces] ⟹
normalized_nnf_match m ⟹
f m = Some m' ⟹
matches (β, α) m' a p = matches (β, α) m a p"
apply(simp)
apply(elim disjE)
using primitive_matcher_generic.compress_normalize_protocols_Some[OF generic] apply blast
using compress_normalize_input_interfaces_Some[OF generic] apply blast
using compress_normalize_output_interfaces_Some[OF generic] apply blast
done
lemma compress_normalize_besteffort_Some:
assumes generic: "primitive_matcher_generic β"
shows "normalized_nnf_match m ⟹
compress_normalize_besteffort m = Some m' ⟹
matches (β, α) m' a p = matches (β, α) m a p"
unfolding compress_normalize_besteffort_def
apply(rule compress_normalize_primitive_monad)
using compress_normalize_besteffort_normalized compress_normalize_besteffort_matches[OF generic] by blast+
lemma compress_normalize_besteffort_None:
assumes generic: "primitive_matcher_generic β"
shows "normalized_nnf_match m ⟹
compress_normalize_besteffort m = None ⟹
¬ matches (β, α) m a p"
proof -
have notmatches: "f ∈ set [compress_normalize_protocols, compress_normalize_input_interfaces, compress_normalize_output_interfaces] ⟹
normalized_nnf_match m ⟹ f m = None ⟹ ¬ matches (β, α) m a p" for f m
apply(simp)
using primitive_matcher_generic.compress_normalize_protocols_None[OF generic]
compress_normalize_input_interfaces_None[OF generic]
compress_normalize_output_interfaces_None[OF generic] by blast
show "normalized_nnf_match m ⟹ compress_normalize_besteffort m = None ⟹ ¬ matches (β, α) m a p"
unfolding compress_normalize_besteffort_def
apply(rule compress_normalize_primitive_monad_None)
using compress_normalize_besteffort_normalized
compress_normalize_besteffort_matches[OF generic]
notmatches by blast+
qed
lemma compress_normalize_besteffort_nnf:
"normalized_nnf_match m ⟹
compress_normalize_besteffort m = Some m' ⟹
normalized_nnf_match m'"
unfolding compress_normalize_besteffort_def
apply(rule compress_normalize_primitive_monad)
using compress_normalize_besteffort_normalized
compress_normalize_besteffort_matches[OF primitive_matcher_generic_common_matcher]
by blast+
lemma compress_normalize_besteffort_not_introduces_Iiface:
"¬ has_disc is_Iiface m ⟹ normalized_nnf_match m ⟹ compress_normalize_besteffort m = Some m' ⟹
¬ has_disc is_Iiface m'"
unfolding compress_normalize_besteffort_def
apply(rule compress_normalize_primitive_monad_preserves[THEN conjunct2])
apply(drule(3) compress_normalize_besteffort_normalized)
apply(auto dest: compress_normalize_input_interfaces_not_introduces_Iiface
compress_normalize_protocols_hasdisc
compress_normalize_output_interfaces_hasdisc)
done
lemma compress_normalize_besteffort_not_introduces_Oiface:
"¬ has_disc is_Oiface m ⟹ normalized_nnf_match m ⟹ compress_normalize_besteffort m = Some m' ⟹
¬ has_disc is_Oiface m'"
unfolding compress_normalize_besteffort_def
apply(rule compress_normalize_primitive_monad_preserves[THEN conjunct2])
apply(drule(3) compress_normalize_besteffort_normalized)
apply(auto dest: compress_normalize_output_interfaces_hasdisc
compress_normalize_output_interfaces_not_introduces_Oiface
compress_normalize_protocols_hasdisc
compress_normalize_input_interfaces_hasdisc)
done
lemma compress_normalize_besteffort_not_introduces_Iiface_negated:
"¬ has_disc_negated is_Iiface False m ⟹ normalized_nnf_match m ⟹ compress_normalize_besteffort m = Some m' ⟹
¬ has_disc_negated is_Iiface False m'"
unfolding compress_normalize_besteffort_def
apply(rule compress_normalize_primitive_monad_preserves[THEN conjunct2])
apply(drule(3) compress_normalize_besteffort_normalized)
apply(auto dest: compress_normalize_besteffort_normalized compress_normalize_input_interfaces_not_introduces_Iiface_negated
compress_normalize_protocols_hasdisc_negated
compress_normalize_output_interfaces_hasdisc_negated)
done
lemma compress_normalize_besteffort_not_introduces_Oiface_negated:
"¬ has_disc_negated is_Oiface False m ⟹ normalized_nnf_match m ⟹ compress_normalize_besteffort m = Some m' ⟹
¬ has_disc_negated is_Oiface False m'"
unfolding compress_normalize_besteffort_def
apply(rule compress_normalize_primitive_monad_preserves[THEN conjunct2])
apply(drule(3) compress_normalize_besteffort_normalized)
apply(auto dest: compress_normalize_output_interfaces_not_introduces_Oiface_negated
compress_normalize_input_interfaces_hasdisc_negated
compress_normalize_protocols_hasdisc_negated)
done
lemma compress_normalize_besteffort_not_introduces_Prot_negated:
"¬ has_disc_negated is_Prot False m ⟹ normalized_nnf_match m ⟹ compress_normalize_besteffort m = Some m' ⟹
¬ has_disc_negated is_Prot False m'"
unfolding compress_normalize_besteffort_def
apply(rule compress_normalize_primitive_monad_preserves[THEN conjunct2])
apply(drule(3) compress_normalize_besteffort_normalized)
apply(auto dest: compress_normalize_input_interfaces_hasdisc_negated
compress_normalize_protocols_not_introduces_Prot_negated
compress_normalize_output_interfaces_hasdisc_negated)
done
lemma compress_normalize_besteffort_hasdisc:
"¬ has_disc disc m ⟹ (∀a. ¬ disc (IIface a)) ⟹ (∀a. ¬ disc (OIface a)) ⟹ (∀a. ¬ disc (Prot a)) ⟹
normalized_nnf_match m ⟹ compress_normalize_besteffort m = Some m' ⟹
normalized_nnf_match m' ∧ ¬ has_disc disc m'"
unfolding compress_normalize_besteffort_def
apply(rule compress_normalize_primitive_monad_preserves)
apply(drule(3) compress_normalize_besteffort_normalized)
apply(auto dest: compress_normalize_input_interfaces_hasdisc
compress_normalize_output_interfaces_hasdisc
compress_normalize_protocols_hasdisc)
done
lemma compress_normalize_besteffort_hasdisc_negated:
"¬ has_disc_negated disc False m ⟹
(∀a. ¬ disc (IIface a)) ⟹ (∀a. ¬ disc (OIface a)) ⟹ (∀a. ¬ disc (Prot a)) ⟹
normalized_nnf_match m ⟹ compress_normalize_besteffort m = Some m' ⟹
normalized_nnf_match m' ∧ ¬ has_disc_negated disc False m'"
unfolding compress_normalize_besteffort_def
apply(rule compress_normalize_primitive_monad_preserves)
apply(drule(3) compress_normalize_besteffort_normalized)
apply(simp split: option.split_asm)
using compress_normalize_input_interfaces_hasdisc_negated
compress_normalize_output_interfaces_hasdisc_negated
compress_normalize_protocols_hasdisc_negated apply blast
apply simp_all
done
lemma compress_normalize_besteffort_preserves_normalized_n_primitive:
"normalized_n_primitive (disc, sel) P m ⟹
(∀a. ¬ disc (IIface a)) ⟹ (∀a. ¬ disc (OIface a)) ⟹ (∀a. ¬ disc (Prot a)) ⟹
normalized_nnf_match m ⟹ compress_normalize_besteffort m = Some m' ⟹
normalized_nnf_match m' ∧ normalized_n_primitive (disc, sel) P m'"
unfolding compress_normalize_besteffort_def
apply(rule compress_normalize_primitive_monad_preserves)
apply(drule(3) compress_normalize_besteffort_normalized)
apply(auto dest: compress_normalize_input_interfaces_preserves_normalized_n_primitive
compress_normalize_output_interfaces_preserves_normalized_n_primitive
compress_normalize_protocols_preserves_normalized_n_primitive)
done
end
section‹Transforming rulesets›
subsection‹Optimizations›
lemma approximating_bigstep_fun_remdups_rev:
"approximating_bigstep_fun γ p (remdups_rev rs) s = approximating_bigstep_fun γ p rs s"
proof(induction γ p rs s rule: approximating_bigstep_fun.induct)
case 1 thus ?case by(simp add: remdups_rev_def)
next
case 2 thus ?case by (simp add: Decision_approximating_bigstep_fun)
next
case (3 γ p m a rs) thus ?case
proof(cases "matches γ m a p")
case False with 3 show ?thesis
by(simp add: remdups_rev_fst remdups_rev_removeAll not_matches_removeAll)
next
case True
{ fix rs s
have "approximating_bigstep_fun γ p (filter ((≠) (Rule m Log)) rs) s = approximating_bigstep_fun γ p rs s"
proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
qed(auto simp add: Decision_approximating_bigstep_fun split: action.split)
} note helper_Log=this
{ fix rs s
have "approximating_bigstep_fun γ p (filter ((≠) (Rule m Empty)) rs) s = approximating_bigstep_fun γ p rs s"
proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
qed(auto simp add: Decision_approximating_bigstep_fun split: action.split)
} note helper_Empty=this
from True 3 show ?thesis
apply(simp add: remdups_rev_fst split: action.split)
apply(safe)
apply(simp_all)
apply(simp_all add: remdups_rev_removeAll)
apply(simp_all add: removeAll_filter_not_eq helper_Empty helper_Log)
done
qed
qed
lemma remdups_rev_simplers: "simple_ruleset rs ⟹ simple_ruleset (remdups_rev rs)"
by(induction rs) (simp_all add: remdups_rev_def simple_ruleset_def)
lemma remdups_rev_preserve_matches:
"∀r∈set rs. P (get_match r) ⟹ ∀r∈set (remdups_rev rs). P (get_match r)"
by(induction rs) (simp_all add: remdups_rev_def simple_ruleset_def)
subsection‹Optimize and Normalize to NNF form›
definition transform_optimize_dnf_strict :: "'i::len common_primitive rule list ⇒ 'i common_primitive rule list" where
"transform_optimize_dnf_strict = cut_off_after_match_any ∘
(optimize_matches opt_MatchAny_match_expr ∘
normalize_rules_dnf ∘ (optimize_matches (opt_MatchAny_match_expr ∘ optimize_primitive_univ)))"
theorem transform_optimize_dnf_strict_structure:
assumes simplers: "simple_ruleset rs" and wfα: "wf_unknown_match_tac α"
shows "simple_ruleset (transform_optimize_dnf_strict rs)"
and "∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹
∀ r ∈ set (transform_optimize_dnf_strict rs). ¬ has_disc disc (get_match r)"
and "∀ r ∈ set (transform_optimize_dnf_strict rs). normalized_nnf_match (get_match r)"
and "∀ r ∈ set rs. normalized_n_primitive disc_sel f (get_match r) ⟹
∀ r ∈ set (transform_optimize_dnf_strict rs). normalized_n_primitive disc_sel f (get_match r)"
and "∀ r ∈ set rs. ¬ has_disc_negated disc neg (get_match r) ⟹
∀ r ∈ set (transform_optimize_dnf_strict rs). ¬ has_disc_negated disc neg (get_match r)"
proof -
show simplers_transform: "simple_ruleset (transform_optimize_dnf_strict rs)"
unfolding transform_optimize_dnf_strict_def
using simplers by (simp add: cut_off_after_match_any_simplers
optimize_matches_simple_ruleset simple_ruleset_normalize_rules_dnf)
define transform_optimize_dnf_strict_inner
where "transform_optimize_dnf_strict_inner =
optimize_matches (opt_MatchAny_match_expr :: 'a common_primitive match_expr ⇒ 'a common_primitive match_expr) ∘
normalize_rules_dnf ∘ (optimize_matches (opt_MatchAny_match_expr ∘ optimize_primitive_univ))"
have inner_outer: "transform_optimize_dnf_strict = (cut_off_after_match_any ∘ transform_optimize_dnf_strict_inner)"
by(auto simp add: transform_optimize_dnf_strict_def transform_optimize_dnf_strict_inner_def)
have tf1: "transform_optimize_dnf_strict_inner (r#rs) =
(optimize_matches opt_MatchAny_match_expr (normalize_rules_dnf (optimize_matches (opt_MatchAny_match_expr ∘ optimize_primitive_univ) [r])))@
transform_optimize_dnf_strict_inner rs" for r rs
unfolding transform_optimize_dnf_strict_inner_def
apply(simp)
apply(subst optimize_matches_fst)
apply(simp add: normalize_rules_dnf_append optimize_matches_append)
done
{ fix P :: "'a::len common_primitive match_expr ⇒ bool"
assume p1: "∀m. P m ⟶ P (optimize_primitive_univ m)"
assume p2: "∀m. P m ⟶ P (opt_MatchAny_match_expr m)"
assume p3: "∀m. P m ⟶ (∀m' ∈ set (normalize_match m). P m')"
{ fix rs
have "∀ r ∈ set rs. P (get_match r) ⟹
∀ r ∈ set (optimize_matches (opt_MatchAny_match_expr ∘ optimize_primitive_univ) rs). P (get_match r)"
apply(rule optimize_matches_preserves)
using p1 p2 by simp
} note opt1=this
{ fix rs
have "∀ r ∈ set rs. P (get_match r) ⟹ ∀ r ∈ set (normalize_rules_dnf rs). P (get_match r)"
apply(induction rs rule: normalize_rules_dnf.induct)
apply(simp; fail)
apply(simp)
apply(safe)
apply(simp_all)
using p3 by(simp)
} note opt2=this
{ fix rs
have "∀ r ∈ set rs. P (get_match r) ⟹
∀ r ∈ set (optimize_matches opt_MatchAny_match_expr rs). P (get_match r)"
apply(rule optimize_matches_preserves)
using p2 by simp
} note opt3=this
have "∀ r ∈ set rs. P (get_match r) ⟹
∀ r ∈ set (transform_optimize_dnf_strict rs). P (get_match r)"
unfolding transform_optimize_dnf_strict_def
apply(drule opt1)
apply(drule opt2)
apply(drule opt3)
using cut_off_after_match_any_preserve_matches by auto
} note matchpred_rule=this
{ fix m
have "¬ has_disc disc m ⟹ ¬ has_disc disc (optimize_primitive_univ m)"
by(induction m rule: optimize_primitive_univ.induct) (simp_all)
} moreover { fix m
have "¬ has_disc disc m ⟶ (∀m' ∈ set (normalize_match m). ¬ has_disc disc m')"
using normalize_match_preserves_nodisc by fast
} ultimately show "∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹
∀ r ∈ set (transform_optimize_dnf_strict rs). ¬ has_disc disc (get_match r)"
using not_has_disc_opt_MatchAny_match_expr matchpred_rule[of "λm. ¬ has_disc disc m"] by fast
{ fix m
have "¬ has_disc_negated disc neg m ⟹ ¬ has_disc_negated disc neg (optimize_primitive_univ m)"
apply(induction disc neg m rule: has_disc_negated.induct)
apply(simp_all)
apply(rename_tac a)
apply(subgoal_tac "optimize_primitive_univ (Match a) = Match a ∨ optimize_primitive_univ (Match a) = MatchAny")
apply safe
apply simp_all
using optimize_primitive_univ_unchanged_primitives by blast
} with not_has_disc_negated_opt_MatchAny_match_expr not_has_disc_normalize_match show
"∀ r ∈ set rs. ¬ has_disc_negated disc neg (get_match r) ⟹
∀ r ∈ set (transform_optimize_dnf_strict rs). ¬ has_disc_negated disc neg (get_match r)"
using matchpred_rule[of "λm. ¬ has_disc_negated disc neg m"] by fast
{ fix P and a::"'a common_primitive"
have "(optimize_primitive_univ (Match a)) = (Match a) ∨ (optimize_primitive_univ (Match a)) = MatchAny"
by(induction "(Match a)" rule: optimize_primitive_univ.induct) (auto)
hence "((optimize_primitive_univ (Match a)) = Match a ⟹ P a) ⟹ (optimize_primitive_univ (Match a) = MatchAny ⟹ P a) ⟹ P a" by blast
} note optimize_primitive_univ_match_cases=this
{ fix m
have "normalized_n_primitive disc_sel f m ⟹ normalized_n_primitive disc_sel f (optimize_primitive_univ m)"
apply(induction disc_sel f m rule: normalized_n_primitive.induct)
apply(simp_all split: if_split_asm)
apply(rule optimize_primitive_univ_match_cases, simp_all)+
done
} moreover { fix m
have "normalized_n_primitive disc_sel f m ⟶ (∀m' ∈ set (normalize_match m). normalized_n_primitive disc_sel f m')"
using normalize_match_preserves_normalized_n_primitive by blast
} ultimately show "∀ r ∈ set rs. normalized_n_primitive disc_sel f (get_match r) ⟹
∀ r ∈ set (transform_optimize_dnf_strict rs). normalized_n_primitive disc_sel f (get_match r)"
using matchpred_rule[of "λm. normalized_n_primitive disc_sel f m"] normalized_n_primitive_opt_MatchAny_match_expr by fast
{ fix rs::"'a::len common_primitive rule list"
from normalize_rules_dnf_normalized_nnf_match[of "rs"]
have "∀x ∈ set (normalize_rules_dnf rs). normalized_nnf_match (get_match x)" .
hence "∀r ∈ set (optimize_matches opt_MatchAny_match_expr (normalize_rules_dnf rs)). normalized_nnf_match (get_match r)"
apply -
apply(rule optimize_matches_preserves)
using normalized_nnf_match_opt_MatchAny_match_expr by blast
}
from this have "∀ r ∈ set (transform_optimize_dnf_strict_inner rs). normalized_nnf_match (get_match r)"
unfolding transform_optimize_dnf_strict_inner_def by simp
thus "∀ r ∈ set (transform_optimize_dnf_strict rs). normalized_nnf_match (get_match r)"
unfolding inner_outer
apply simp
apply(rule cut_off_after_match_any_preserve_matches)
.
qed
theorem transform_optimize_dnf_strict:
assumes simplers: "simple_ruleset rs" and wfα: "wf_unknown_match_tac α"
shows "(common_matcher, α),p⊢ ⟨transform_optimize_dnf_strict rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
proof -
let ?γ="(common_matcher, α)"
let ?fw="λrs. approximating_bigstep_fun ?γ p rs s"
have simplers_transform: "simple_ruleset (transform_optimize_dnf_strict rs)"
unfolding transform_optimize_dnf_strict_def
using simplers by (simp add: cut_off_after_match_any_simplers
optimize_matches_simple_ruleset simple_ruleset_normalize_rules_dnf)
have simplers1: "simple_ruleset (optimize_matches (opt_MatchAny_match_expr ∘ optimize_primitive_univ) rs)"
using simplers optimize_matches_simple_ruleset by (metis)
have 1: "?γ,p⊢ ⟨rs, s⟩ ⇒⇩α t ⟷ ?fw rs = t"
using approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]] by fast
have "?fw rs = ?fw (optimize_matches (opt_MatchAny_match_expr ∘ optimize_primitive_univ) rs)"
apply(rule optimize_matches[symmetric])
using optimize_primitive_univ_correct_matchexpr opt_MatchAny_match_expr_correct by (metis comp_apply)
also have "… = ?fw (normalize_rules_dnf (optimize_matches (opt_MatchAny_match_expr ∘ optimize_primitive_univ) rs))"
apply(rule normalize_rules_dnf_correct[symmetric])
using simplers1 by (metis good_imp_wf_ruleset simple_imp_good_ruleset)
also have "… = ?fw (optimize_matches opt_MatchAny_match_expr (normalize_rules_dnf (optimize_matches (opt_MatchAny_match_expr ∘ optimize_primitive_univ) rs)))"
apply(rule optimize_matches[symmetric])
using opt_MatchAny_match_expr_correct by (metis)
finally have rs: "?fw rs = ?fw (transform_optimize_dnf_strict rs)"
unfolding transform_optimize_dnf_strict_def by(simp add: cut_off_after_match_any)
have 2: "?fw (transform_optimize_dnf_strict rs) = t ⟷ ?γ,p⊢ ⟨transform_optimize_dnf_strict rs, s⟩ ⇒⇩α t "
using approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers_transform], symmetric] by fast
from 1 2 rs show "?γ,p⊢ ⟨transform_optimize_dnf_strict rs, s⟩ ⇒⇩α t ⟷ ?γ,p⊢ ⟨rs, s⟩ ⇒⇩α t" by simp
qed
subsection‹Abstracting over unknowns›
definition transform_remove_unknowns_generic
:: "('a, 'packet) match_tac ⇒ 'a rule list ⇒ 'a rule list"
where
"transform_remove_unknowns_generic γ = optimize_matches_a (remove_unknowns_generic γ) "
theorem transform_remove_unknowns_generic:
assumes simplers: "simple_ruleset rs"
and wfα: "wf_unknown_match_tac α" and packet_independent_α: "packet_independent_α α"
and wfβ: "packet_independent_β_unknown β"
shows "(β, α),p⊢ ⟨transform_remove_unknowns_generic (β, α) rs, s⟩ ⇒⇩α t ⟷ (β, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
and "simple_ruleset (transform_remove_unknowns_generic (β, α) rs)"
and "∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹
∀ r ∈ set (transform_remove_unknowns_generic (β, α) rs). ¬ has_disc disc (get_match r)"
and "∀ r ∈ set (transform_remove_unknowns_generic (β, α) rs). ¬ has_unknowns β (get_match r)"
and "∀ r ∈ set rs. normalized_n_primitive disc_sel f (get_match r) ⟹
∀ r ∈ set (transform_remove_unknowns_generic (β, α) rs). normalized_n_primitive disc_sel f (get_match r)"
and "∀ r ∈ set rs. ¬ has_disc_negated disc neg (get_match r) ⟹
∀ r ∈ set (transform_remove_unknowns_generic (β, α) rs). ¬ has_disc_negated disc neg (get_match r)"
proof -
let ?γ="(β, α)"
let ?fw="λrs. approximating_bigstep_fun ?γ p rs s"
show simplers1: "simple_ruleset (transform_remove_unknowns_generic ?γ rs)"
unfolding transform_remove_unknowns_generic_def
using simplers optimize_matches_a_simple_ruleset by blast
show "?γ,p⊢ ⟨transform_remove_unknowns_generic ?γ rs, s⟩ ⇒⇩α t ⟷ ?γ,p⊢ ⟨rs, s⟩ ⇒⇩α t"
unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers1]]
unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]]
unfolding transform_remove_unknowns_generic_def
using optimize_matches_a_simplers[OF simplers] remove_unknowns_generic by metis
from remove_unknowns_generic_not_has_disc show
"∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹
∀ r ∈ set (transform_remove_unknowns_generic ?γ rs). ¬ has_disc disc (get_match r)"
unfolding transform_remove_unknowns_generic_def
by(intro optimize_matches_a_preserves) blast
from remove_unknowns_generic_normalized_n_primitive show
"∀ r ∈ set rs. normalized_n_primitive disc_sel f (get_match r) ⟹
∀ r ∈ set (transform_remove_unknowns_generic ?γ rs). normalized_n_primitive disc_sel f (get_match r)"
unfolding transform_remove_unknowns_generic_def
by(intro optimize_matches_a_preserves) blast
show "∀ r ∈ set (transform_remove_unknowns_generic ?γ rs). ¬ has_unknowns β (get_match r)"
unfolding transform_remove_unknowns_generic_def
apply(rule optimize_matches_a_preserves)
apply(rule remove_unknowns_generic_specification[OF _ packet_independent_α wfβ])
using simplers by(simp add: simple_ruleset_def)
from remove_unknowns_generic_not_has_disc_negated show
"∀ r ∈ set rs. ¬ has_disc_negated disc neg (get_match r) ⟹
∀ r ∈ set (transform_remove_unknowns_generic ?γ rs). ¬ has_disc_negated disc neg (get_match r)"
unfolding transform_remove_unknowns_generic_def
by(rule optimize_matches_a_preserves) blast
qed
thm transform_remove_unknowns_generic[OF _ _ _ packet_independent_β_unknown_common_matcher]
corollary transform_remove_unknowns_upper: defines "upper ≡ optimize_matches_a upper_closure_matchexpr"
assumes simplers: "simple_ruleset rs"
shows "(common_matcher, in_doubt_allow),p⊢ ⟨upper rs, s⟩ ⇒⇩α t ⟷ (common_matcher, in_doubt_allow),p⊢ ⟨rs, s⟩ ⇒⇩α t"
and "simple_ruleset (upper rs)"
and "∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹
∀ r ∈ set (upper rs). ¬ has_disc disc (get_match r)"
and "∀ r ∈ set (upper rs). ¬ has_disc is_Extra (get_match r)"
and "∀ r ∈ set rs. normalized_n_primitive disc_sel f (get_match r) ⟹
∀ r ∈ set (upper rs). normalized_n_primitive disc_sel f (get_match r)"
and "∀ r ∈ set rs. ¬ has_disc_negated disc neg (get_match r) ⟹
∀ r ∈ set (upper rs). ¬ has_disc_negated disc neg (get_match r)"
proof -
from simplers have upper: "upper rs = transform_remove_unknowns_generic (common_matcher, in_doubt_allow) rs"
apply(simp add: transform_remove_unknowns_generic_def upper_def)
apply(erule optimize_matches_a_simple_ruleset_eq)
by (simp add: upper_closure_matchexpr_generic)
note * = transform_remove_unknowns_generic[OF
simplers wf_in_doubt_allow packet_independent_unknown_match_tacs(1) packet_independent_β_unknown_common_matcher,
simplified upper_closure_matchexpr_generic]
from *(1)[where p = p]
show "(common_matcher, in_doubt_allow),p⊢ ⟨upper rs, s⟩ ⇒⇩α t ⟷ (common_matcher, in_doubt_allow),p⊢ ⟨rs, s⟩ ⇒⇩α t"
by(subst upper)
from *(2) show "simple_ruleset (upper rs)" by(subst upper)
from *(3) show "∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹
∀ r ∈ set (upper rs). ¬ has_disc disc (get_match r)"
by(subst upper) fast
from *(4) show "∀ r ∈ set (upper rs). ¬ has_disc is_Extra (get_match r)"
apply(subst upper)
using has_unknowns_common_matcher by auto
from *(5) show "∀ r ∈ set rs. normalized_n_primitive disc_sel f (get_match r) ⟹
∀ r ∈ set (upper rs). normalized_n_primitive disc_sel f (get_match r)"
apply(subst upper)
using packet_independent_unknown_match_tacs(1) simplers
transform_remove_unknowns_generic(5)[OF _ _ _ packet_independent_β_unknown_common_matcher] wf_in_doubt_allow
by blast
from *(6) show "∀ r ∈ set rs. ¬ has_disc_negated disc neg (get_match r) ⟹
∀ r ∈ set (upper rs). ¬ has_disc_negated disc neg (get_match r)"
by(subst upper) fast
qed
corollary transform_remove_unknowns_lower: defines "lower ≡ optimize_matches_a lower_closure_matchexpr"
assumes simplers: "simple_ruleset rs"
shows "(common_matcher, in_doubt_deny),p⊢ ⟨lower rs, s⟩ ⇒⇩α t ⟷ (common_matcher, in_doubt_deny),p⊢ ⟨rs, s⟩ ⇒⇩α t"
and "simple_ruleset (lower rs)"
and "∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹
∀ r ∈ set (lower rs). ¬ has_disc disc (get_match r)"
and "∀ r ∈ set (lower rs). ¬ has_disc is_Extra (get_match r)"
and "∀ r ∈ set rs. normalized_n_primitive disc_sel f (get_match r) ⟹
∀ r ∈ set (lower rs). normalized_n_primitive disc_sel f (get_match r)"
and "∀ r ∈ set rs. ¬ has_disc_negated disc neg (get_match r) ⟹
∀ r ∈ set (lower rs). ¬ has_disc_negated disc neg (get_match r)"
proof -
from simplers have lower: "lower rs = transform_remove_unknowns_generic (common_matcher, in_doubt_deny) rs"
apply(simp add: transform_remove_unknowns_generic_def lower_def)
apply(erule optimize_matches_a_simple_ruleset_eq)
by (simp add: lower_closure_matchexpr_generic)
note * = transform_remove_unknowns_generic[OF
simplers wf_in_doubt_deny packet_independent_unknown_match_tacs(2) packet_independent_β_unknown_common_matcher,
simplified lower_closure_matchexpr_generic]
from *(1)[where p = p]
show "(common_matcher, in_doubt_deny),p⊢ ⟨lower rs, s⟩ ⇒⇩α t ⟷ (common_matcher, in_doubt_deny),p⊢ ⟨rs, s⟩ ⇒⇩α t"
by(subst lower)
from *(2) show "simple_ruleset (lower rs)" by(subst lower)
from *(3) show "∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹
∀ r ∈ set (lower rs). ¬ has_disc disc (get_match r)"
by(subst lower) fast
from *(4) show "∀ r ∈ set (lower rs). ¬ has_disc is_Extra (get_match r)"
apply(subst lower)
using has_unknowns_common_matcher by auto
from *(5) show "∀ r ∈ set rs. normalized_n_primitive disc_sel f (get_match r) ⟹
∀ r ∈ set (lower rs). normalized_n_primitive disc_sel f (get_match r)"
apply(subst lower)
using packet_independent_unknown_match_tacs(1) simplers
transform_remove_unknowns_generic(5)[OF _ _ _ packet_independent_β_unknown_common_matcher] wf_in_doubt_deny
by blast
from *(6) show "∀ r ∈ set rs. ¬ has_disc_negated disc neg (get_match r) ⟹
∀ r ∈ set (lower rs). ¬ has_disc_negated disc neg (get_match r)"
by(subst lower) fast
qed
subsection‹Normalizing and Transforming Primitives›
text‹Rewrite the primitives IPs and Ports such that can be used by the simple firewall.›
definition transform_normalize_primitives :: "'i::len common_primitive rule list ⇒ 'i common_primitive rule list" where
"transform_normalize_primitives =
optimize_matches_option compress_normalize_besteffort ∘
normalize_rules normalize_dst_ips ∘
normalize_rules normalize_src_ips ∘
normalize_rules normalize_dst_ports ∘
normalize_rules normalize_src_ports ∘
normalize_rules rewrite_MultiportPorts "
thm normalize_primitive_extract_preserves_unrelated_normalized_n_primitive
lemma normalize_rules_preserves_unrelated_normalized_n_primitive:
assumes "∀ r ∈ set rs. normalized_nnf_match (get_match r) ∧ normalized_n_primitive (disc2, sel2) P (get_match r)"
and "wf_disc_sel (disc1, sel1) C"
and "∀a. ¬ disc2 (C a)"
shows "∀r ∈ set (normalize_rules (normalize_primitive_extract (disc1, sel1) C f) rs).
normalized_nnf_match (get_match r) ∧ normalized_n_primitive (disc2, sel2) P (get_match r)"
thm normalize_rules_preserves[where P="λm. normalized_nnf_match m ∧ normalized_n_primitive (disc2, sel2) P m"
and f="normalize_primitive_extract (disc1, sel1) C f"]
apply(rule normalize_rules_preserves[where P="λm. normalized_nnf_match m ∧ normalized_n_primitive (disc2, sel2) P m"
and f="normalize_primitive_extract (disc1, sel1) C f"])
using assms(1) apply(simp)
apply(safe)
using normalize_primitive_extract_preserves_nnf_normalized[OF _ assms(2)] apply fast
using normalize_primitive_extract_preserves_unrelated_normalized_n_primitive[OF _ _ assms(2) assms(3)] by blast
lemma normalize_rules_normalized_n_primitive:
assumes "∀ r ∈ set rs. normalized_nnf_match (get_match r)"
and "∀m. normalized_nnf_match m ⟶
(∀m' ∈ set (normalize_primitive_extract (disc, sel) C f m). normalized_n_primitive (disc, sel) P m')"
shows "∀r ∈ set (normalize_rules (normalize_primitive_extract (disc, sel) C f) rs).
normalized_n_primitive (disc, sel) P (get_match r)"
apply(rule normalize_rules_property[where P=normalized_nnf_match and f="normalize_primitive_extract (disc, sel) C f"])
using assms(1) apply simp
using assms(2) by simp
lemma optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive:
assumes "∀ r ∈ set rs. normalized_nnf_match (get_match r) ∧ normalized_n_primitive (disc2, sel2) P (get_match r)"
and "∀a. ¬ disc2 (IIface a)" and "∀a. ¬ disc2 (OIface a)" and "∀a. ¬ disc2 (Prot a)"
shows "∀r ∈ set (optimize_matches_option compress_normalize_besteffort rs).
normalized_nnf_match (get_match r) ∧ normalized_n_primitive (disc2, sel2) P (get_match r)"
thm optimize_matches_option_preserves
apply(rule optimize_matches_option_preserves[where P="λm. normalized_nnf_match m ∧ normalized_n_primitive (disc2, sel2) P m"
and f="compress_normalize_besteffort"])
apply(rule compress_normalize_besteffort_preserves_normalized_n_primitive)
apply(simp_all add: assms)
done
theorem transform_normalize_primitives:
defines "unchanged disc ≡ (∀a. ¬ disc (Src_Ports a)) ∧ (∀a. ¬ disc (Dst_Ports a)) ∧
(∀a. ¬ disc (Src a)) ∧ (∀a. ¬ disc (Dst a))"
and "changeddisc disc ≡ ((∀a. ¬ disc (IIface a)) ∨ disc = is_Iiface) ∧
((∀a. ¬ disc (OIface a)) ∨ disc = is_Oiface)"
assumes simplers: "simple_ruleset (rs :: 'i::len common_primitive rule list)"
and wfα: "wf_unknown_match_tac α"
and normalized: "∀ r ∈ set rs. normalized_nnf_match (get_match r)"
shows "(common_matcher, α),p⊢ ⟨transform_normalize_primitives rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
and "simple_ruleset (transform_normalize_primitives rs)"
and "unchanged disc1 ⟹ changeddisc disc1 ⟹ ∀a. ¬ disc1 (Prot a) ⟹
∀ r ∈ set rs. ¬ has_disc disc1 (get_match r) ⟹
∀ r ∈ set (transform_normalize_primitives rs). ¬ has_disc disc1 (get_match r)"
and "∀ r ∈ set (transform_normalize_primitives rs). normalized_nnf_match (get_match r)"
and "∀ r ∈ set (transform_normalize_primitives rs).
normalized_src_ports (get_match r) ∧ normalized_dst_ports (get_match r) ∧
normalized_src_ips (get_match r) ∧ normalized_dst_ips (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
and "unchanged disc2 ⟹ (∀a. ¬ disc2 (IIface a)) ⟹ (∀a. ¬ disc2 (OIface a)) ⟹ (∀a. ¬ disc2 (Prot a)) ⟹
∀ r ∈ set rs. normalized_n_primitive (disc2, sel2) f (get_match r) ⟹
∀ r ∈ set (transform_normalize_primitives rs). normalized_n_primitive (disc2, sel2) f (get_match r)"
and "unchanged disc3 ⟹ changeddisc disc3 ⟹
(∀a. ¬ disc3 (Prot a)) ∨
(disc3 = is_Prot ∧ (∀ r ∈ set rs.
¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r))) ⟹
∀ r ∈ set rs. ¬ has_disc_negated disc3 False (get_match r) ⟹
∀ r ∈ set (transform_normalize_primitives rs). ¬ has_disc_negated disc3 False (get_match r)"
proof -
let ?γ="(common_matcher, α)"
let ?fw="λrs. approximating_bigstep_fun ?γ p rs s"
show simplers_t: "simple_ruleset (transform_normalize_primitives rs)"
unfolding transform_normalize_primitives_def
by(simp add: simple_ruleset_normalize_rules simplers optimize_matches_option_simple_ruleset)
let ?rs0="normalize_rules rewrite_MultiportPorts rs"
let ?rs1="normalize_rules normalize_src_ports ?rs0"
let ?rs2="normalize_rules normalize_dst_ports ?rs1"
let ?rs3="normalize_rules normalize_src_ips ?rs2"
let ?rs4="normalize_rules normalize_dst_ips ?rs3"
let ?rs5="optimize_matches_option compress_normalize_besteffort ?rs4"
have normalized_rs0: "∀r ∈ set ?rs0. normalized_nnf_match (get_match r)"
apply(intro normalize_rules_preserves[OF normalized])
apply(simp add: rewrite_MultiportPorts_def)
using normalized_nnf_match_normalize_match by blast
from normalize_src_ports_nnf have normalized_rs1: "∀r ∈ set ?rs1. normalized_nnf_match (get_match r)"
apply(intro normalize_rules_preserves[OF normalized_rs0])
using normalize_dst_ports_nnf by blast
from normalize_dst_ports_nnf have normalized_rs2: "∀r ∈ set ?rs2. normalized_nnf_match (get_match r)"
apply(intro normalize_rules_preserves[OF normalized_rs1])
by blast
from normalize_rules_primitive_extract_preserves_nnf_normalized[OF this wf_disc_sel_common_primitive(3)]
normalize_src_ips_def
have normalized_rs3: "∀r ∈ set ?rs3. normalized_nnf_match (get_match r)" by metis
from normalize_rules_primitive_extract_preserves_nnf_normalized[OF this wf_disc_sel_common_primitive(4)]
normalize_dst_ips_def
have normalized_rs4: "∀r ∈ set ?rs4. normalized_nnf_match (get_match r)" by metis
have normalized_rs5: "∀r ∈ set ?rs5. normalized_nnf_match (get_match r)"
apply(intro optimize_matches_option_preserves)
apply(erule compress_normalize_besteffort_nnf[rotated])
by(simp add: normalized_rs4)
thus "∀ r ∈ set (transform_normalize_primitives rs). normalized_nnf_match (get_match r)"
unfolding transform_normalize_primitives_def by simp
have local_simp: "⋀rs1 rs2. approximating_bigstep_fun ?γ p rs1 s = approximating_bigstep_fun ?γ p rs2 s ⟹
(approximating_bigstep_fun ?γ p rs1 s = t) = (approximating_bigstep_fun ?γ p rs2 s = t)" by simp
have opt_compress_rule:
"approximating_bigstep_fun (common_matcher, α) p (optimize_matches_option compress_normalize_besteffort rs1) s =
approximating_bigstep_fun (common_matcher, α) p rs2 s"
if rs1_n: "∀r ∈ set rs1. normalized_nnf_match (get_match r)"
and rs1rs2: "approximating_bigstep_fun (common_matcher, α) p rs1 s =
approximating_bigstep_fun (common_matcher, α) p rs2 s" for rs1 rs2
apply(subst optimize_matches_option_generic[where P="λ m a. normalized_nnf_match m"])
apply(simp_all add: normalized
compress_normalize_besteffort_Some[OF primitive_matcher_generic_common_matcher]
compress_normalize_besteffort_None[OF primitive_matcher_generic_common_matcher]
rs1_n)
using rs1rs2 by simp
show "?γ,p⊢ ⟨transform_normalize_primitives rs, s⟩ ⇒⇩α t ⟷ ?γ,p⊢ ⟨rs, s⟩ ⇒⇩α t"
unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers_t]]
unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]]
unfolding transform_normalize_primitives_def
apply(simp)
apply(subst local_simp, simp_all)
apply(rule opt_compress_rule[OF normalized_rs4])
apply(subst normalize_rules_match_list_semantics_3[of normalized_nnf_match])
using normalize_dst_ips[where p = p] apply(simp; fail)
using simplers simple_ruleset_normalize_rules apply blast
using normalized_rs3 apply(simp; fail)
apply(subst normalize_rules_match_list_semantics_3[of normalized_nnf_match])
using normalize_src_ips[where p = p] apply(simp; fail)
using simplers simple_ruleset_normalize_rules apply blast
using normalized_rs2 apply(simp; fail)
apply(subst normalize_rules_match_list_semantics_3[of normalized_nnf_match])
using normalize_dst_ports[OF primitive_matcher_generic_common_matcher,where p = p] apply(simp; fail)
using simplers simple_ruleset_normalize_rules apply blast
using normalized_rs1 apply(simp; fail)
apply(subst normalize_rules_match_list_semantics_3[of normalized_nnf_match])
using normalize_src_ports[OF primitive_matcher_generic_common_matcher, where p = p] apply(simp; fail)
using simplers simple_ruleset_normalize_rules apply blast
using normalized_rs0 apply(simp; fail)
apply(subst normalize_rules_match_list_semantics_3[of normalized_nnf_match])
using rewrite_MultiportPorts[OF primitive_matcher_generic_common_matcher, where p = p] apply(simp; fail)
using simplers apply blast
using normalized apply(simp; fail)
..
from rewrite_MultiportPorts_removes_MultiportsPorts
normalize_rules_property[OF normalized, where f=rewrite_MultiportPorts and Q="λm. ¬ has_disc is_MultiportPorts m"]
have rewrite_MultiportPorts_normalizes_Multiports:
"∀r ∈ set ?rs0. ¬ has_disc is_MultiportPorts (get_match r)"
by blast
from normalize_src_ports_normalized_n_primitive
have normalized_src_ports: "∀r ∈ set ?rs1. normalized_src_ports (get_match r)"
apply(intro normalize_rules_property[OF normalized_rs0, where f=normalize_src_ports and Q=normalized_src_ports])
by blast
from normalize_dst_ports_normalized_n_primitive
normalize_rules_property[OF normalized_rs1, where f=normalize_dst_ports and Q=normalized_dst_ports]
have normalized_dst_ports: "∀r ∈ set ?rs2. normalized_dst_ports (get_match r)" by fast
from normalize_src_ips_normalized_n_primitive
normalize_rules_property[OF normalized_rs2, where f=normalize_src_ips and Q=normalized_src_ips]
have normalized_src_ips: "∀r ∈ set ?rs3. normalized_src_ips (get_match r)" by fast
from normalize_dst_ips_normalized_n_primitive
normalize_rules_property[OF normalized_rs3, where f=normalize_dst_ips and Q=normalized_dst_ips]
normalized_rs4
have normalized_dst_ips_rs4: "∀r ∈ set ?rs4. normalized_nnf_match (get_match r) ∧ normalized_dst_ips (get_match r)" by fast
with optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive[
of _ is_Dst dst_sel normalized_cidr_ip
, folded normalized_dst_ips_def2]
have normalized_dst_rs5: "∀r ∈ set ?rs5. normalized_dst_ips (get_match r)" by fastforce
have normalize_dst_ports_preserves_normalized_src_ports:
"m' ∈ set (normalize_dst_ports m) ⟹ normalized_nnf_match m ⟹
normalized_src_ports m ⟹ normalized_src_ports m'" for m m' :: " 'i common_primitive match_expr"
unfolding normalized_src_ports_def2
apply(rule normalize_ports_generic_preserves_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(2)])
apply(simp_all)
by (simp add: normalize_dst_ports_def normalize_ports_generic_def normalize_positive_dst_ports_def rewrite_negated_dst_ports_def)
from normalize_rules_preserves_unrelated_normalized_n_primitive[of
_ is_MultiportPorts multiportports_sel "λ_. False"]
have preserve_normalized_multiport_ports: "
∀r∈ set rs. normalized_nnf_match (get_match r) ⟹
∀r∈ set rs. ¬ has_disc is_MultiportPorts (get_match r) ⟹
wf_disc_sel (disc, sel) C ⟹
∀a. ¬ is_MultiportPorts (C a) ⟹
∀r∈ set (normalize_rules (normalize_primitive_extract (disc, sel) C f) rs).
¬ has_disc is_MultiportPorts (get_match r)"
for f :: "'c negation_type list ⇒ 'c list" and rs disc sel
and C :: "'c ⇒ 'i::len common_primitive"
using normalized_n_primitive_false_eq_notdisc
by blast
have normalized_multiportports_rs1: "∀r ∈ set ?rs1. ¬ has_disc is_MultiportPorts (get_match r)"
apply(rule normalize_rules_property[where P="λm. normalized_nnf_match m ∧ ¬ has_disc is_MultiportPorts m"])
using normalized_rs0 rewrite_MultiportPorts_normalizes_Multiports apply blast
apply(intro allI impI ballI)
apply(rule normalize_src_ports_preserves_normalized_not_has_disc)
by(simp_all)
have normalized_multiportports_rs2: "∀r ∈ set ?rs2. ¬ has_disc is_MultiportPorts (get_match r)"
apply(rule normalize_rules_property[where P="λm. normalized_nnf_match m ∧ ¬ has_disc is_MultiportPorts m"])
using normalized_rs1 normalized_multiportports_rs1 apply blast
apply(intro allI impI ballI)
apply(rule normalize_dst_ports_preserves_normalized_not_has_disc)
by(simp_all)
from preserve_normalized_multiport_ports[OF normalized_rs2 normalized_multiportports_rs2 wf_disc_sel_common_primitive(3),
where f2=ipt_iprange_compress, folded normalize_src_ips_def]
have normalized_multiportports_rs3: "∀r ∈ set ?rs3. ¬ has_disc is_MultiportPorts (get_match r)" by simp
from preserve_normalized_multiport_ports[OF normalized_rs3 normalized_multiportports_rs3 wf_disc_sel_common_primitive(4),
where f2=ipt_iprange_compress, folded normalize_dst_ips_def]
normalized_rs4
have normalized_multiportports_rs4: "∀r ∈ set ?rs4. normalized_nnf_match (get_match r) ∧ ¬ has_disc is_MultiportPorts (get_match r)" by simp
with optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive[
of _ is_MultiportPorts multiportports_sel "λ_. False"
, simplified]
have normalized_multiportports_rs5: "∀r ∈ set ?rs5. ¬ has_disc is_MultiportPorts (get_match r)"
using normalized_n_primitive_false_eq_notdisc by fastforce
from normalize_rules_preserves_unrelated_normalized_n_primitive[of _ is_Src_Ports src_ports_sel "(λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1)",
folded normalized_src_ports_def2]
have preserve_normalized_src_ports: "
∀r∈ set rs. normalized_nnf_match (get_match r) ⟹
∀r∈ set rs. normalized_src_ports (get_match r) ⟹
wf_disc_sel (disc, sel) C ⟹
∀a. ¬ is_Src_Ports (C a) ⟹
∀r∈ set (normalize_rules (normalize_primitive_extract (disc, sel) C f) rs). normalized_src_ports (get_match r)"
for f :: "'c negation_type list ⇒ 'c list" and rs disc sel and C :: "'c ⇒ 'i::len common_primitive"
by blast
have normalized_src_ports_rs2: "∀r ∈ set ?rs2. normalized_src_ports (get_match r)"
apply(rule normalize_rules_property[where P="λm. normalized_nnf_match m ∧ normalized_src_ports m"])
using normalized_rs1 normalized_src_ports apply blast
apply(clarify)
using normalize_dst_ports_preserves_normalized_src_ports by blast
from preserve_normalized_src_ports[OF normalized_rs2 normalized_src_ports_rs2 wf_disc_sel_common_primitive(3),
where f3=ipt_iprange_compress, folded normalize_src_ips_def]
have normalized_src_ports_rs3: "∀r ∈ set ?rs3. normalized_src_ports (get_match r)" by simp
from preserve_normalized_src_ports[OF normalized_rs3 normalized_src_ports_rs3 wf_disc_sel_common_primitive(4),
where f3=ipt_iprange_compress, folded normalize_dst_ips_def]
normalized_rs4
have normalized_src_ports_rs4: "∀r ∈ set ?rs4. normalized_nnf_match (get_match r) ∧ normalized_src_ports (get_match r)" by simp
with optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive[
of _ is_Src_Ports src_ports_sel "(λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1)"
, folded normalized_src_ports_def2]
have normalized_src_ports_rs5: "∀r ∈ set ?rs5. normalized_src_ports (get_match r)" by fastforce
from normalize_rules_preserves_unrelated_normalized_n_primitive[of _ is_Dst_Ports dst_ports_sel "(λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1)",
folded normalized_dst_ports_def2]
have preserve_normalized_dst_ports: "⋀rs disc sel C f.
∀r∈set rs. normalized_nnf_match (get_match r) ⟹
∀r∈set rs. normalized_dst_ports (get_match r) ⟹
wf_disc_sel (disc, sel) C ⟹
∀a. ¬ is_Dst_Ports (C a) ⟹
∀r∈ set (normalize_rules (normalize_primitive_extract (disc, sel) C f) rs). normalized_dst_ports (get_match r)"
by blast
from preserve_normalized_dst_ports[OF normalized_rs2 normalized_dst_ports wf_disc_sel_common_primitive(3),
where f3=ipt_iprange_compress, folded normalize_src_ips_def]
have normalized_dst_ports_rs3: "∀r ∈ set ?rs3. normalized_dst_ports (get_match r)" by force
from preserve_normalized_dst_ports[OF normalized_rs3 normalized_dst_ports_rs3 wf_disc_sel_common_primitive(4),
where f3=ipt_iprange_compress, folded normalize_dst_ips_def]
normalized_rs4
have normalized_dst_ports_rs4: "∀r ∈ set ?rs4. normalized_nnf_match (get_match r) ∧ normalized_dst_ports (get_match r)" by force
with optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive[
of _ is_Dst_Ports dst_ports_sel "(λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1)"
, folded normalized_dst_ports_def2]
have normalized_dst_ports_rs5: "∀r ∈ set ?rs5. normalized_dst_ports (get_match r)" by fastforce
from normalize_rules_preserves_unrelated_normalized_n_primitive[of ?rs3 is_Src src_sel normalized_cidr_ip,
OF _ wf_disc_sel_common_primitive(4),
where f=ipt_iprange_compress, folded normalize_dst_ips_def normalized_src_ips_def2]
normalized_rs3 normalized_src_ips
have normalized_src_rs4: "∀r ∈ set ?rs4. normalized_nnf_match (get_match r) ∧ normalized_src_ips (get_match r)" by force
with optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive[
of _ is_Src src_sel normalized_cidr_ip
, folded normalized_src_ips_def2]
have normalized_src_rs5: "∀r ∈ set ?rs5. normalized_src_ips (get_match r)"
by fastforce
from normalized_multiportports_rs5 normalized_src_ports_rs5
normalized_dst_ports_rs5 normalized_src_rs5 normalized_dst_rs5
show "∀ r ∈ set (transform_normalize_primitives rs).
normalized_src_ports (get_match r) ∧ normalized_dst_ports (get_match r) ∧
normalized_src_ips (get_match r) ∧ normalized_dst_ips (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
unfolding transform_normalize_primitives_def by simp
show "unchanged disc2 ⟹ (∀a. ¬ disc2 (IIface a)) ⟹ (∀a. ¬ disc2 (OIface a)) ⟹ (∀a. ¬ disc2 (Prot a)) ⟹
∀ r ∈ set rs. normalized_n_primitive (disc2, sel2) f (get_match r) ⟹
∀ r ∈ set (transform_normalize_primitives rs). normalized_n_primitive (disc2, sel2) f (get_match r)"
unfolding unchanged_def
proof(elim conjE)
assume "∀r∈ set rs. normalized_n_primitive (disc2, sel2) f (get_match r)"
with normalized have a':
"∀r∈ set rs. normalized_nnf_match (get_match r) ∧ normalized_n_primitive (disc2, sel2) f (get_match r)" by blast
assume a_Src_Ports: "∀a. ¬ disc2 (Src_Ports a)"
assume a_Dst_Ports: "∀a. ¬ disc2 (Dst_Ports a)"
assume a_Src: "∀a. ¬ disc2 (Src a)"
assume a_Dst: "∀a. ¬ disc2 (Dst a)"
assume a_IIface: "(∀a. ¬ disc2 (IIface a))"
assume a_OIface: "(∀a. ¬ disc2 (OIface a))"
assume a_Prot: "(∀a. ¬ disc2 (Prot a))"
have normalized_n_primitive_rs0:
"∀r∈set ?rs0. normalized_n_primitive (disc2, sel2) f (get_match r)"
apply(intro normalize_rules_property[where P="λm. normalized_nnf_match m ∧ normalized_n_primitive (disc2, sel2) f m"])
using a' apply blast
using rewrite_MultiportPorts_preserves_normalized_n_primitive[OF _ a_Src_Ports a_Dst_Ports] by blast
have normalized_n_primitive_rs1:
"∀r∈set ?rs1. normalized_n_primitive (disc2, sel2) f (get_match r)"
apply(rule normalize_rules_property[where P="λm. normalized_nnf_match m ∧ normalized_n_primitive (disc2, sel2) f m"])
using normalized_n_primitive_rs0 normalized_rs0 apply blast
using normalize_src_ports_preserves_normalized_n_primitive[OF _ a_Src_Ports] a_Prot by blast
have "∀r∈set ?rs2. normalized_n_primitive (disc2, sel2) f (get_match r)"
apply(rule normalize_rules_property[where P="λm. normalized_nnf_match m ∧ normalized_n_primitive (disc2, sel2) f m"])
using normalized_n_primitive_rs1 normalized_rs1 apply blast
using normalize_dst_ports_preserves_normalized_n_primitive[OF _ a_Dst_Ports] a_Prot by blast
with normalized_rs2 normalize_rules_preserves_unrelated_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(3) a_Src,
of ?rs2 sel2 f ipt_iprange_compress,
folded normalize_src_ips_def]
have "∀r∈set ?rs3. normalized_n_primitive (disc2, sel2) f (get_match r)" by blast
with normalized_rs3 normalize_rules_preserves_unrelated_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(4) a_Dst,
of ?rs3 sel2 f ipt_iprange_compress,
folded normalize_dst_ips_def]
have "∀r∈set ?rs4. normalized_nnf_match (get_match r) ∧ normalized_n_primitive (disc2, sel2) f (get_match r)" by blast
hence "∀r∈set ?rs5. normalized_nnf_match (get_match r) ∧ normalized_n_primitive (disc2, sel2) f (get_match r)"
apply(intro optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive)
using a_IIface a_OIface a_Prot by simp_all
thus ?thesis
unfolding transform_normalize_primitives_def by simp
qed
{ fix m and m' and disc::"('i::len common_primitive ⇒ bool)"
and sel::"('i::len common_primitive ⇒ 'x)" and C'::" ('x ⇒ 'i::len common_primitive)"
and f'::"('x negation_type list ⇒ 'x list)"
assume am: "¬ has_disc disc1 m"
and nm: "normalized_nnf_match m"
and am': "m' ∈ set (normalize_primitive_extract (disc, sel) C' f' m)"
and wfdiscsel: "wf_disc_sel (disc,sel) C'"
and disc_different: "∀a. ¬ disc1 (C' a)"
from disc_different have af: "∀spts. (∀a ∈ Match ` C' ` set (f' spts). ¬ has_disc disc1 a)"
by(simp)
obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
from am' asms have "m' ∈ (λspt. MatchAnd (Match (C' spt)) ms) ` set (f' as)"
unfolding normalize_primitive_extract_def by(simp)
hence goalrule:"∀spt ∈ set (f' as). ¬ has_disc disc1 (Match (C' spt)) ⟹ ¬ has_disc disc1 ms ⟹ ¬ has_disc disc1 m'" by fastforce
from am primitive_extractor_correct(4)[OF nm wfdiscsel asms] have 1: "¬ has_disc disc1 ms" by simp
from af have 2: "∀spt ∈ set (f' as). ¬ has_disc disc1 (Match (C' spt))" by simp
from goalrule[OF 2 1] have "¬ has_disc disc1 m'" .
moreover from nm have "normalized_nnf_match m'" by (metis am' normalize_primitive_extract_preserves_nnf_normalized wfdiscsel)
ultimately have "¬ has_disc disc1 m' ∧ normalized_nnf_match m'" by simp
}
hence x: "⋀disc sel C' f'. wf_disc_sel (disc, sel) C' ⟹ ∀a. ¬ disc1 (C' a) ⟹
∀m. normalized_nnf_match m ∧ ¬ has_disc disc1 m ⟶
(∀m'∈set (normalize_primitive_extract (disc, sel) C' f' m). normalized_nnf_match m' ∧ ¬ has_disc disc1 m')"
by blast
from normalize_src_ports_preserves_normalized_not_has_disc normalize_src_ports_nnf have x_src_ports:
"∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Prot a) ⟹
m' ∈ set (normalize_src_ports m) ⟹
normalized_nnf_match m ⟹ ¬ has_disc disc m ⟹ ¬ has_disc disc m' ∧ normalized_nnf_match m'"
for m m' and disc :: "'i common_primitive ⇒ bool" by blast
from normalize_dst_ports_preserves_normalized_not_has_disc normalize_dst_ports_nnf have x_dst_ports:
"∀a. ¬ disc (Dst_Ports a) ⟹ ∀a. ¬ disc (Prot a) ⟹
m'∈ set (normalize_dst_ports m) ⟹
normalized_nnf_match m ⟹ ¬ has_disc disc m ⟹ ¬ has_disc disc m' ∧ normalized_nnf_match m'"
for m m' and disc :: "'i common_primitive ⇒ bool" by blast
{ fix rs
assume "(∀a. ¬ disc1 (IIface a)) ∨ disc1 = is_Iiface"
and "((∀a. ¬ disc1 (OIface a)) ∨ disc1 = is_Oiface)"
and "(∀a. ¬ disc1 (Prot a))"
hence "∀m∈set rs. ¬ has_disc disc1 (get_match m) ∧ normalized_nnf_match (get_match m) ⟹
∀m∈set (optimize_matches_option compress_normalize_besteffort rs).
normalized_nnf_match (get_match m) ∧ ¬ has_disc disc1 (get_match m)"
apply -
apply(rule optimize_matches_option_preserves)
apply(elim disjE)
using compress_normalize_besteffort_hasdisc apply blast
using compress_normalize_besteffort_nnf compress_normalize_besteffort_not_introduces_Iiface
compress_normalize_besteffort_not_introduces_Oiface by blast+
} note y=this
have "∀a. ¬ disc1 (Src_Ports a) ⟹ ∀a. ¬ disc1 (Dst_Ports a) ⟹
∀a. ¬ disc1 (Src a) ⟹ ∀a. ¬ disc1 (Dst a) ⟹
(∀a. ¬ disc1 (IIface a)) ∨ disc1 = is_Iiface ⟹
(∀a. ¬ disc1 (OIface a)) ∨ disc1 = is_Oiface ⟹ (∀a. ¬ disc1 (Prot a)) ⟹
∀ r∈set rs. ¬ has_disc disc1 (get_match r) ∧ normalized_nnf_match (get_match r) ⟹
∀ r ∈ set (transform_normalize_primitives rs). normalized_nnf_match (get_match r) ∧ ¬ has_disc disc1 (get_match r)"
unfolding transform_normalize_primitives_def
apply(simp)
apply(rule y)
apply(simp; fail)
apply(simp; fail)
apply(simp; fail)
apply(rule normalize_rules_preserves)+
apply(simp; fail)
subgoal
apply(intro allI impI conjI ballI)
apply(rule rewrite_MultiportPorts_preserves_normalized_not_has_disc, simp_all)
by(simp add: rewrite_MultiportPorts_normalized_nnf_match)
subgoal
apply clarify
apply(rule x_src_ports)
by simp+
subgoal
apply clarify
by(rule x_dst_ports) simp+
using x[OF wf_disc_sel_common_primitive(3), of ipt_iprange_compress,folded normalize_src_ips_def] apply blast
using x[OF wf_disc_sel_common_primitive(4), of ipt_iprange_compress,folded normalize_dst_ips_def] apply blast
done
thus "unchanged disc1 ⟹ changeddisc disc1 ⟹ ∀a. ¬ disc1 (Prot a) ⟹
∀ r ∈ set rs. ¬ has_disc disc1 (get_match r) ⟹
∀ r ∈ set (transform_normalize_primitives rs). ¬ has_disc disc1 (get_match r)"
unfolding unchanged_def changeddisc_def using normalized by blast
{ fix m and m' and disc::"('i::len common_primitive ⇒ bool)"
and sel::"('i::len common_primitive ⇒ 'x)" and C'::" ('x ⇒ 'i::len common_primitive)"
and f'::"('x negation_type list ⇒ 'x list)" and neg
and disc3
assume am: "¬ has_disc_negated disc3 neg m"
and nm: "normalized_nnf_match m"
and am': "m' ∈ set (normalize_primitive_extract (disc, sel) C' f' m)"
and wfdiscsel: "wf_disc_sel (disc,sel) C'"
and disc_different: "∀a. ¬ disc3 (C' a)"
from disc_different have af: "∀spts. (∀a ∈ Match ` C' ` set (f' spts). ¬ has_disc disc3 a)"
by(simp)
obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
from am' asms have "m' ∈ (λspt. MatchAnd (Match (C' spt)) ms) ` set (f' as)"
unfolding normalize_primitive_extract_def by(simp)
hence goalrule:"∀spt ∈ set (f' as). ¬ has_disc_negated disc3 neg (Match (C' spt)) ⟹
¬ has_disc_negated disc3 neg ms ⟹ ¬ has_disc_negated disc3 neg m'" by fastforce
from am primitive_extractor_correct(6)[OF nm wfdiscsel asms] have 1: "¬ has_disc_negated disc3 neg ms" by simp
from af have 2: "∀spt ∈ set (f' as). ¬ has_disc_negated disc3 neg (Match (C' spt))" by simp
from goalrule[OF 2 1] have "¬ has_disc_negated disc3 neg m'" .
moreover from nm have "normalized_nnf_match m'" by (metis am' normalize_primitive_extract_preserves_nnf_normalized wfdiscsel)
ultimately have "¬ has_disc_negated disc3 neg m' ∧ normalized_nnf_match m'" by simp
}
note x_generic=this
hence x: "wf_disc_sel (disc, sel) C' ⟹ ∀a. ¬ disc3 (C' a) ⟹
∀m. normalized_nnf_match m ∧ ¬ has_disc_negated disc3 False m ⟶
(∀m' ∈ set (normalize_primitive_extract (disc, sel) C' f' m).
normalized_nnf_match m' ∧ ¬ has_disc_negated disc3 False m')"
for disc :: "'i common_primitive ⇒ bool" and sel and C' :: "'c ⇒ 'i common_primitive" and f' and disc3
by blast
from normalize_src_ports_preserves_normalized_not_has_disc_negated normalize_src_ports_nnf have x_src_ports:
"∀a. ¬ disc (Src_Ports a) ⟹ (∀a. ¬ disc (Prot a)) ∨ ¬ has_disc_negated is_Src_Ports False m ⟹
m' ∈ set (normalize_src_ports m) ⟹
normalized_nnf_match m ⟹ ¬ has_disc_negated disc False m ⟹
¬ has_disc_negated disc False m' ∧ normalized_nnf_match m'"
for m m' and disc :: "'i common_primitive ⇒ bool" by blast
from normalize_dst_ports_preserves_normalized_not_has_disc_negated normalize_dst_ports_nnf have x_dst_ports:
"∀a. ¬ disc (Src_Ports a) ⟹ (∀a. ¬ disc (Prot a)) ∨ ¬ has_disc_negated is_Dst_Ports False m ⟹
m' ∈ set (normalize_dst_ports m) ⟹
normalized_nnf_match m ⟹ ¬ has_disc_negated disc False m ⟹
¬ has_disc_negated disc False m' ∧ normalized_nnf_match m'"
for m m' and disc :: "'i common_primitive ⇒ bool" by blast
{ fix rs
fix P :: "'i common_primitive match_expr ⇒ bool"
assume "(∀a. ¬ disc3 (IIface a)) ∨ disc3 = is_Iiface"
and "(∀a. ¬ disc3 (OIface a)) ∨ disc3 = is_Oiface"
and "(∀a. ¬ disc3 (Prot a)) ∨ disc3 = is_Prot"
and P_prop: "∀m m'. normalized_nnf_match m ⟶ P m ⟶ compress_normalize_besteffort m = Some m' ⟶ P m'"
hence
"∀r∈set rs. ¬ has_disc_negated disc3 False (get_match r) ∧ normalized_nnf_match (get_match r) ∧ P (get_match r) ⟹
∀r∈set (optimize_matches_option compress_normalize_besteffort rs).
normalized_nnf_match (get_match r) ∧ ¬ has_disc_negated disc3 False (get_match r) ∧ P (get_match r)"
apply -
thm optimize_matches_option_preserves[where P=
"λm. normalized_nnf_match m ∧ ¬ has_disc_negated disc3 False m ∧ P m"]
apply(rule optimize_matches_option_preserves[where P=
"λm. normalized_nnf_match m ∧ ¬ has_disc_negated disc3 False m ∧ P m"])
apply(elim disjE)
using compress_normalize_besteffort_nnf compress_normalize_besteffort_hasdisc_negated apply blast
using compress_normalize_besteffort_nnf
compress_normalize_besteffort_not_introduces_Iiface_negated
compress_normalize_besteffort_not_introduces_Oiface_negated
compress_normalize_besteffort_not_introduces_Prot_negated by blast+
} note y_generic=this
note y=y_generic[of "λ_. True", simplified]
have case_disc3_is_not_prot: "∀a. ¬ disc3 (Src_Ports a) ⟹ ∀a. ¬ disc3 (Dst_Ports a) ⟹
∀a. ¬ disc3 (Src a) ⟹ ∀a. ¬ disc3 (Dst a) ⟹
(∀a. ¬ disc3 (IIface a)) ∨ disc3 = is_Iiface ⟹
(∀a. ¬ disc3 (OIface a)) ∨ disc3 = is_Oiface ⟹
(∀a. ¬ disc3 (Prot a)) ⟹
∀ r ∈ set rs. ¬ has_disc_negated disc3 False (get_match r) ∧ normalized_nnf_match (get_match r) ⟹
∀ r ∈ set (transform_normalize_primitives rs). normalized_nnf_match (get_match r) ∧ ¬ has_disc_negated disc3 False (get_match r)"
unfolding transform_normalize_primitives_def
apply(simp)
apply(rule y)
apply(simp; fail)
apply(simp; fail)
apply(blast)
apply(rule normalize_rules_preserves)+
apply(simp; fail)
subgoal
apply(intro allI impI conjI ballI)
apply(rule rewrite_MultiportPorts_preserves_normalized_not_has_disc_negated, simp_all)
by(simp add: rewrite_MultiportPorts_normalized_nnf_match)
subgoal
apply(clarify)
apply(rule_tac m6=m in x_src_ports)
by(simp)+
subgoal
apply(clarify)
by(rule x_dst_ports) simp+
using x[OF wf_disc_sel_common_primitive(3), of disc3 ipt_iprange_compress, folded normalize_src_ips_def] apply blast
using x[OF wf_disc_sel_common_primitive(4), of disc3 ipt_iprange_compress, folded normalize_dst_ips_def] apply blast
done
have case_disc3_is_prot_optimize_matches_option:"∀r∈set rs.
¬ has_disc_negated is_Prot False (get_match r) ∧
normalized_nnf_match (get_match r) ∧
¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ⟹
∀r∈set (optimize_matches_option compress_normalize_besteffort rs).
normalized_nnf_match (get_match r) ∧
¬ has_disc_negated is_Prot False (get_match r) ∧
¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r)"
if isprot: "disc3 = is_Prot"
for rs :: "'i common_primitive rule list"
apply(rule y_generic[where P8="λm. ¬ has_disc_negated is_Src_Ports False m ∧ ¬ has_disc_negated is_Dst_Ports False m", simplified isprot])
apply simp+
apply(clarify)
apply(intro conjI)
using compress_normalize_besteffort_hasdisc_negated[of is_Src_Ports] apply fastforce
using compress_normalize_besteffort_hasdisc_negated[of is_Dst_Ports] apply fastforce
by simp
have case_disc3_is_prot: "disc3 = is_Prot ⟹
∀ r ∈ set rs. ¬ has_disc_negated disc3 False (get_match r) ∧ normalized_nnf_match (get_match r) ∧
¬ has_disc_negated is_Src_Ports False (get_match r) ∧ ¬ has_disc_negated is_Dst_Ports False (get_match r) &
¬ has_disc is_MultiportPorts (get_match r) ⟹
∀ r ∈ set (transform_normalize_primitives rs). normalized_nnf_match (get_match r) ∧ ¬ has_disc_negated disc3 False (get_match r) ∧
¬ has_disc_negated is_Src_Ports False (get_match r) ∧ ¬ has_disc_negated is_Dst_Ports False (get_match r)"
unfolding transform_normalize_primitives_def
apply(simp)
apply(rule case_disc3_is_prot_optimize_matches_option)
apply(simp; fail)
thm normalize_rules_property[
where P="λm. normalized_nnf_match m ∧ ¬ has_disc_negated disc3 False m"]
apply(rule normalize_rules_property[
where P="λm. normalized_nnf_match m ∧
¬ has_disc_negated disc3 False m ∧
¬ has_disc_negated is_Src_Ports False m ∧
¬ has_disc_negated is_Dst_Ports False m"])
apply(rule normalize_rules_property[
where P="λm. normalized_nnf_match m ∧
¬ has_disc_negated disc3 False m ∧
¬ has_disc_negated is_Src_Ports False m ∧
¬ has_disc_negated is_Dst_Ports False m"])
apply(rule normalize_rules_property[
where P="λm. normalized_nnf_match m ∧
¬ has_disc_negated disc3 False m ∧
¬ has_disc_negated is_Src_Ports False m ∧
¬ has_disc_negated is_Dst_Ports False m"])
apply(rule normalize_rules_property[
where P="λm. normalized_nnf_match m ∧
¬ has_disc_negated disc3 False m ∧
¬ has_disc_negated is_Src_Ports False m ∧
¬ has_disc_negated is_Dst_Ports False m"])
apply(rule normalize_rules_property[
where P="λm. normalized_nnf_match m ∧
¬ has_disc_negated disc3 False m ∧
¬ has_disc_negated is_Src_Ports False m ∧
¬ has_disc_negated is_Dst_Ports False m ∧
¬ has_disc is_MultiportPorts m"])
apply(simp; fail)
subgoal
apply(intro allI impI conjI ballI)
apply(simp add: rewrite_MultiportPorts_normalized_nnf_match; fail)
apply(rule rewrite_MultiportPorts_preserves_normalized_not_has_disc_negated, simp_all)
using rewrite_MultiportPorts_unchanged_if_not_has_disc by fastforce+
subgoal
apply(clarify)
apply(frule_tac m6=m in x_src_ports[rotated 2])
apply(simp_all)
apply simp
using normalize_src_ports_preserves_normalized_not_has_disc_negated by blast
subgoal
apply(clarify)
apply(frule_tac m6=m in x_dst_ports[rotated 2])
apply(simp_all)
apply simp
using normalize_dst_ports_preserves_normalized_not_has_disc_negated by blast
using x[OF wf_disc_sel_common_primitive(3), of disc3 ipt_iprange_compress, folded normalize_src_ips_def]
x[OF wf_disc_sel_common_primitive(3), of is_Dst_Ports ipt_iprange_compress, folded normalize_src_ips_def]
x_generic[OF _ _ _ wf_disc_sel_common_primitive(3), of is_Src_Ports False _ _ ipt_iprange_compress, folded normalize_src_ips_def]
apply (meson common_primitive.disc(45) common_primitive.disc(56) common_primitive.disc(67); fail)
using x[OF wf_disc_sel_common_primitive(4), of disc3 ipt_iprange_compress, folded normalize_dst_ips_def]
x[OF wf_disc_sel_common_primitive(4), of is_Src_Ports ipt_iprange_compress, folded normalize_dst_ips_def]
x_generic[OF _ _ _ wf_disc_sel_common_primitive(4), of is_Dst_Ports False _ _ ipt_iprange_compress, folded normalize_dst_ips_def]
apply (meson common_primitive.disc(46) common_primitive.disc(57) common_primitive.disc(68); fail)
done
show "unchanged disc3 ⟹ changeddisc disc3 ⟹
(∀a. ¬ disc3 (Prot a)) ∨
(disc3 = is_Prot ∧ (∀ r ∈ set rs.
¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r))) ⟹
∀ r ∈ set rs. ¬ has_disc_negated disc3 False (get_match r) ⟹
∀ r ∈ set (transform_normalize_primitives rs). ¬ has_disc_negated disc3 False (get_match r)"
unfolding unchanged_def changeddisc_def
apply(elim disjE)
using normalized case_disc3_is_not_prot apply blast
using normalized case_disc3_is_prot by blast
qed
theorem iiface_constrain:
assumes simplers: "simple_ruleset rs"
and normalized: "∀ r ∈ set rs. normalized_nnf_match (get_match r)"
and wf_ipassmt: "ipassmt_sanity_nowildcards ipassmt"
and nospoofing: "⋀ips. ipassmt (Iface (p_iiface p)) = Some ips ⟹ p_src p ∈ ipcidr_union_set (set ips)"
shows "(common_matcher, α),p⊢ ⟨optimize_matches (iiface_constrain ipassmt) rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
and "simple_ruleset (optimize_matches (iiface_constrain ipassmt) rs)"
proof -
show simplers_t: "simple_ruleset (optimize_matches (iiface_constrain ipassmt) rs)"
by (simp add: optimize_matches_simple_ruleset simplers)
have my_arg_cong: "⋀P Q. P s = Q s ⟹ (P s = t) ⟷ (Q s = t)" by simp
show "(common_matcher, α),p⊢ ⟨optimize_matches (iiface_constrain ipassmt) rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers_t]]
unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]]
apply(rule my_arg_cong)
apply(rule optimize_matches_generic[where P="λ m _. normalized_nnf_match m"])
apply(simp add: normalized)
apply(rule matches_iiface_constrain)
apply(simp_all add: wf_ipassmt nospoofing)
done
qed
text‹In contrast to @{thm iiface_constrain}, this requires @{const ipassmt_sanity_disjoint} and
as much stronger nospoof assumption: This assumption requires that the packet is actually in ipassmt!›
theorem iiface_rewrite:
assumes simplers: "simple_ruleset rs"
and normalized: "∀ r ∈ set rs. normalized_nnf_match (get_match r)"
and wf_ipassmt: "ipassmt_sanity_nowildcards ipassmt"
and disjoint_ipassmt: "ipassmt_sanity_disjoint ipassmt"
and nospoofing: "∃ips. ipassmt (Iface (p_iiface p)) = Some ips ∧ p_src p ∈ ipcidr_union_set (set ips)"
shows "(common_matcher, α),p⊢ ⟨optimize_matches (iiface_rewrite ipassmt) rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
and "simple_ruleset (optimize_matches (iiface_rewrite ipassmt) rs)"
proof -
show simplers_t: "simple_ruleset (optimize_matches (iiface_rewrite ipassmt) rs)"
by(simp add: simplers optimize_matches_simple_ruleset)
from nospoofing have "Iface (p_iiface p) ∈ dom ipassmt" by blast
have my_arg_cong: "⋀P Q. P s = Q s ⟹ (P s = t) ⟷ (Q s = t)" by simp
show "(common_matcher, α),p⊢ ⟨optimize_matches (iiface_rewrite ipassmt) rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers_t]]
unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]]
apply(rule my_arg_cong)
apply(rule optimize_matches_generic[where P="λ m _. normalized_nnf_match m"])
apply(simp add: normalized)
apply(rule matches_iiface_rewrite)
apply(simp_all add: wf_ipassmt nospoofing disjoint_ipassmt)
done
qed
theorem oiface_rewrite:
assumes simplers: "simple_ruleset rs"
and normalized: "∀ r ∈ set rs. normalized_nnf_match (get_match r)"
and wf_ipassmt: "ipassmt_sanity_nowildcards ipassmt"
and ipassmt_from_rt: "ipassmt = map_of (routing_ipassmt rt)"
and correct_routing: "correct_routing rt"
and rtbl_decided: "output_iface (routing_table_semantics rt (p_dst p)) = p_oiface p"
shows "(common_matcher, α),p⊢ ⟨optimize_matches (oiface_rewrite ipassmt) rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
and "simple_ruleset (optimize_matches (oiface_rewrite ipassmt) rs)"
proof -
show simplers_t: "simple_ruleset (optimize_matches (oiface_rewrite ipassmt) rs)"
using simplers by(fact optimize_matches_simple_ruleset)
show "(common_matcher, α),p⊢ ⟨optimize_matches (oiface_rewrite ipassmt) rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers_t]]
unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]]
apply(rule arg_cong[where f="λx. x = t"])
apply(rule optimize_matches_generic[where P="λ m _. normalized_nnf_match m"])
apply(simp add: normalized ;fail)
apply(rule matches_oiface_rewrite[OF _ _ _ ipassmt_from_rt]; assumption?)
apply(simp_all add: wf_ipassmt correct_routing rtbl_decided)
done
qed
definition upper_closure :: "'i::len common_primitive rule list ⇒ 'i common_primitive rule list" where
"upper_closure rs == remdups_rev (transform_optimize_dnf_strict
(transform_normalize_primitives (transform_optimize_dnf_strict (optimize_matches_a upper_closure_matchexpr rs))))"
definition lower_closure :: "'i::len common_primitive rule list ⇒ 'i common_primitive rule list" where
"lower_closure rs == remdups_rev (transform_optimize_dnf_strict
(transform_normalize_primitives (transform_optimize_dnf_strict (optimize_matches_a lower_closure_matchexpr rs))))"
text‹putting it all together›
lemma transform_upper_closure:
assumes simplers: "simple_ruleset rs"
shows "(common_matcher, in_doubt_allow),p⊢ ⟨upper_closure rs, s⟩ ⇒⇩α t ⟷ (common_matcher, in_doubt_allow),p⊢ ⟨rs, s⟩ ⇒⇩α t"
and "simple_ruleset (upper_closure rs)"
and "∀ r ∈ set (upper_closure rs). normalized_nnf_match (get_match r) ∧
normalized_src_ports (get_match r) ∧
normalized_dst_ports (get_match r) ∧
normalized_src_ips (get_match r) ∧
normalized_dst_ips (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r) ∧
¬ has_disc is_Extra (get_match r)"
and "∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Dst_Ports a) ⟹ ∀a. ¬ disc (Src a) ⟹ ∀a. ¬ disc (Dst a) ⟹
∀a. ¬ disc (IIface a) ∨ disc = is_Iiface ⟹ ∀a. ¬ disc (OIface a) ∨ disc = is_Oiface ⟹
∀a. ¬ disc (Prot a) ⟹
∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹ ∀ r ∈ set (upper_closure rs). ¬ has_disc disc (get_match r)"
and "∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Dst_Ports a) ⟹ ∀a. ¬ disc (Src a) ⟹ ∀a. ¬ disc (Dst a) ⟹
∀a. ¬ disc (IIface a) ∨ disc = is_Iiface ⟹ ∀a. ¬ disc (OIface a) ∨ disc = is_Oiface ⟹
(∀a. ¬ disc (Prot a)) ∨
disc = is_Prot ∧
(∀ r ∈ set rs. ¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)) ⟹
∀ r ∈ set rs. ¬ has_disc_negated disc False (get_match r) ⟹
∀ r ∈ set (upper_closure rs). ¬ has_disc_negated disc False (get_match r)"
proof -
let ?rs1="optimize_matches_a upper_closure_matchexpr rs"
let ?rs2="transform_optimize_dnf_strict ?rs1"
let ?rs3="transform_normalize_primitives ?rs2"
let ?rs4="transform_optimize_dnf_strict ?rs3"
{ fix m a
have "Rule m a ∈ set (upper_closure rs) ⟹
(a = action.Accept ∨ a = action.Drop) ∧
normalized_nnf_match m ∧
normalized_src_ports m ∧
normalized_dst_ports m ∧
normalized_src_ips m ∧
normalized_dst_ips m ∧
¬ has_disc is_MultiportPorts m ∧
¬ has_disc is_Extra m"
using simplers
unfolding upper_closure_def
apply(simp add: remdups_rev_set)
apply(frule transform_remove_unknowns_upper(4))
apply(drule transform_remove_unknowns_upper(2))
thm transform_optimize_dnf_strict[OF _ wf_in_doubt_allow]
apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_allow, where disc=is_Extra])
apply(thin_tac "∀r∈ set (optimize_matches_a upper_closure_matchexpr rs). ¬ has_disc is_Extra (get_match r)")
apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_allow])
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
thm transform_normalize_primitives[OF _ wf_in_doubt_allow]
apply(frule(1) transform_normalize_primitives(3)[OF _ wf_in_doubt_allow, of _ is_Extra])
apply(simp;fail)
apply(simp;fail)
apply(simp;fail)
apply blast
apply(thin_tac "∀r∈ set ?rs2. ¬ has_disc is_Extra (get_match r)")
apply(frule(1) transform_normalize_primitives(5)[OF _ wf_in_doubt_allow])
apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_allow], simp)
thm transform_optimize_dnf_strict[OF _ wf_in_doubt_allow]
apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_allow, where disc=is_Extra])
apply(frule transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_allow, where disc=is_MultiportPorts])
apply blast
apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_allow])
apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_allow, of _ "(is_Src_Ports, src_ports_sel)" "(λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1)"])
apply(simp add: normalized_src_ports_def2; fail)
apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_allow, of _ "(is_Dst_Ports, dst_ports_sel)" "(λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1)"])
apply(simp add: normalized_dst_ports_def2; fail)
apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_allow, of _ "(is_Src, src_sel)" normalized_cidr_ip])
apply(simp add: normalized_src_ips_def2; fail)
apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_allow, of _ "(is_Dst, dst_sel)" normalized_cidr_ip])
apply(simp add: normalized_dst_ips_def2; fail)
apply(thin_tac "∀r∈set ?rs2. _ r")+
apply(thin_tac "∀r∈set ?rs3. _ r")+
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
apply(subgoal_tac "(a = action.Accept ∨ a = action.Drop)")
prefer 2
apply(simp_all add: simple_ruleset_def)
apply fastforce
apply(simp add: normalized_src_ports_def2 normalized_dst_ports_def2 normalized_src_ips_def2 normalized_dst_ips_def2)
apply(intro conjI)
by fastforce+
} note 1=this
from 1 show "simple_ruleset (upper_closure rs)"
apply(simp add: simple_ruleset_def)
apply(clarify)
apply(rename_tac r)
apply(case_tac r)
apply(simp)
by blast
from 1 show "∀ r ∈ set (upper_closure rs). normalized_nnf_match (get_match r) ∧
normalized_src_ports (get_match r) ∧
normalized_dst_ports (get_match r) ∧
normalized_src_ips (get_match r) ∧
normalized_dst_ips (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r) ∧
¬ has_disc is_Extra (get_match r)"
apply(clarify)
apply(rename_tac r)
apply(case_tac r)
apply(simp)
done
show "∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Dst_Ports a) ⟹ ∀a. ¬ disc (Src a) ⟹ ∀a. ¬ disc (Dst a) ⟹
∀a. ¬ disc (IIface a) ∨ disc = is_Iiface ⟹ ∀a. ¬ disc (OIface a) ∨ disc = is_Oiface ⟹
∀a. ¬ disc (Prot a) ⟹
∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹ ∀ r ∈ set (upper_closure rs). ¬ has_disc disc (get_match r)"
using simplers
unfolding upper_closure_def
apply -
apply(frule(1) transform_remove_unknowns_upper(3)[where disc=disc])
apply(drule transform_remove_unknowns_upper(2))
apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_allow, where disc=disc])
apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_allow])
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
apply(frule(1) transform_normalize_primitives(3)[OF _ wf_in_doubt_allow, of _ disc])
apply(simp;fail)
apply blast
apply(simp;fail)
apply(simp;fail)
apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_allow], simp)
apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_allow, where disc=disc])
apply(simp add: remdups_rev_set)
done
have no_ports_1:
"¬ has_disc_negated is_Src_Ports False (get_match m) ∧
¬ has_disc_negated is_Dst_Ports False (get_match m) ∧
¬ has_disc is_MultiportPorts (get_match m)"
if no_ports: "∀r∈set rs.
¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
and m: "m ∈ set (transform_optimize_dnf_strict (optimize_matches_a upper_closure_matchexpr rs))"
for m
proof -
from no_ports transform_remove_unknowns_upper(3,6)[OF simplers] have
"∀r∈ set (optimize_matches_a upper_closure_matchexpr rs).
¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
by blast
with m transform_optimize_dnf_strict_structure(2,5)[OF optimize_matches_a_simple_ruleset[OF simplers] wf_in_doubt_allow, of upper_closure_matchexpr]
show ?thesis by blast
qed
show"∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Dst_Ports a) ⟹ ∀a. ¬ disc (Src a) ⟹ ∀a. ¬ disc (Dst a) ⟹
∀a. ¬ disc (IIface a) ∨ disc = is_Iiface ⟹ ∀a. ¬ disc (OIface a) ∨ disc = is_Oiface ⟹
(∀a. ¬ disc (Prot a)) ∨ disc = is_Prot ∧
(∀ r ∈ set rs. ¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)) ⟹
∀ r ∈ set rs. ¬ has_disc_negated disc False (get_match r) ⟹
∀ r ∈ set (upper_closure rs). ¬ has_disc_negated disc False (get_match r)"
using simplers
unfolding upper_closure_def
apply -
apply(frule(1) transform_remove_unknowns_upper(6)[where disc=disc])
apply(drule transform_remove_unknowns_upper(2))
apply(frule(1) transform_optimize_dnf_strict_structure(5)[OF _ wf_in_doubt_allow, where disc=disc])
apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_allow])
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
apply(frule(1) transform_normalize_primitives(7)[OF _ wf_in_doubt_allow, of _ disc])
apply(simp;fail)
apply blast
apply(elim disjE)
apply blast
apply(simp)
using no_ports_1 apply fast
apply(simp;fail)
apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_allow], simp)
apply(frule(1) transform_optimize_dnf_strict_structure(5)[OF _ wf_in_doubt_allow, where disc=disc])
apply(simp add: remdups_rev_set)
done
show "(common_matcher, in_doubt_allow),p⊢ ⟨upper_closure rs, s⟩ ⇒⇩α t ⟷ (common_matcher, in_doubt_allow),p⊢ ⟨rs, s⟩ ⇒⇩α t"
using simplers
unfolding upper_closure_def
apply -
apply(frule transform_remove_unknowns_upper(1)[where p=p and s=s and t=t])
apply(drule transform_remove_unknowns_upper(2))
apply(frule transform_optimize_dnf_strict[OF _ wf_in_doubt_allow, where p=p and s=s and t=t])
apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_allow])
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
apply(frule(1) transform_normalize_primitives(1)[OF _ wf_in_doubt_allow, where p=p and s=s and t=t])
apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_allow], simp)
apply(frule transform_optimize_dnf_strict[OF _ wf_in_doubt_allow, where p=p and s=s and t=t])
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
apply(simp)
using approximating_bigstep_fun_remdups_rev
by (simp add: approximating_bigstep_fun_remdups_rev approximating_semantics_iff_fun_good_ruleset remdups_rev_simplers simple_imp_good_ruleset)
qed
lemma transform_lower_closure:
assumes simplers: "simple_ruleset rs"
shows "(common_matcher, in_doubt_deny),p⊢ ⟨lower_closure rs, s⟩ ⇒⇩α t ⟷ (common_matcher, in_doubt_deny),p⊢ ⟨rs, s⟩ ⇒⇩α t"
and "simple_ruleset (lower_closure rs)"
and "∀ r ∈ set (lower_closure rs). normalized_nnf_match (get_match r) ∧
normalized_src_ports (get_match r) ∧
normalized_dst_ports (get_match r) ∧
normalized_src_ips (get_match r) ∧
normalized_dst_ips (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r) ∧
¬ has_disc is_Extra (get_match r)"
and "∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Dst_Ports a) ⟹ ∀a. ¬ disc (Src a) ⟹ ∀a. ¬ disc (Dst a) ⟹
∀a. ¬ disc (IIface a) ∨ disc = is_Iiface ⟹ ∀a. ¬ disc (OIface a) ∨ disc = is_Oiface ⟹
∀a. ¬ disc (Prot a) ⟹
∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹
∀ r ∈ set (lower_closure rs). ¬ has_disc disc (get_match r)"
and "∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Dst_Ports a) ⟹ ∀a. ¬ disc (Src a) ⟹ ∀a. ¬ disc (Dst a) ⟹
∀a. ¬ disc (IIface a) ∨ disc = is_Iiface ⟹ ∀a. ¬ disc (OIface a) ∨ disc = is_Oiface ⟹
(∀a. ¬ disc (Prot a)) ∨ disc = is_Prot ∧
(∀ r ∈ set rs. ¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)) ⟹
∀ r ∈ set rs. ¬ has_disc_negated disc False (get_match r) ⟹
∀ r ∈ set (lower_closure rs). ¬ has_disc_negated disc False (get_match r)"
proof -
let ?rs1="optimize_matches_a lower_closure_matchexpr rs"
let ?rs2="transform_optimize_dnf_strict ?rs1"
let ?rs3="transform_normalize_primitives ?rs2"
let ?rs4="transform_optimize_dnf_strict ?rs3"
{ fix m a
have "Rule m a ∈ set (lower_closure rs) ⟹
(a = action.Accept ∨ a = action.Drop) ∧
normalized_nnf_match m ∧
normalized_src_ports m ∧
normalized_dst_ports m ∧
normalized_src_ips m ∧
normalized_dst_ips m ∧
¬ has_disc is_MultiportPorts m ∧
¬ has_disc is_Extra m"
using simplers
unfolding lower_closure_def
apply(simp add: remdups_rev_set)
apply(frule transform_remove_unknowns_lower(4))
apply(drule transform_remove_unknowns_lower(2))
thm transform_optimize_dnf_strict[OF _ wf_in_doubt_deny]
apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_deny, where disc=is_Extra])
apply(thin_tac "∀r∈ set (optimize_matches_a lower_closure_matchexpr rs). ¬ has_disc is_Extra (get_match r)")
apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_deny])
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
thm transform_normalize_primitives[OF _ wf_in_doubt_deny]
apply(frule(1) transform_normalize_primitives(3)[OF _ wf_in_doubt_deny, of _ is_Extra])
apply(simp;fail)
apply(simp;fail)
apply(simp;fail)
apply blast
apply(thin_tac "∀r∈ set ?rs2. ¬ has_disc is_Extra (get_match r)")
apply(frule(1) transform_normalize_primitives(5)[OF _ wf_in_doubt_deny])
apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_deny], simp)
thm transform_optimize_dnf_strict[OF _ wf_in_doubt_deny]
apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_deny, where disc=is_Extra])
apply(frule transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_deny, where disc=is_MultiportPorts])
apply blast
apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_deny])
apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_deny, of _ "(is_Src_Ports, src_ports_sel)" "(λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1)"])
apply(simp add: normalized_src_ports_def2; fail)
apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_deny, of _ "(is_Dst_Ports, dst_ports_sel)" "(λps. case ps of L4Ports _ pts ⇒ length pts ≤ 1)"])
apply(simp add: normalized_dst_ports_def2; fail)
apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_deny, of _ "(is_Src, src_sel)" normalized_cidr_ip])
apply(simp add: normalized_src_ips_def2; fail)
apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_deny, of _ "(is_Dst, dst_sel)" normalized_cidr_ip])
apply(simp add: normalized_dst_ips_def2; fail)
apply(thin_tac "∀r∈set ?rs2. _ r")+
apply(thin_tac "∀r∈set ?rs3. _ r")+
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
apply(subgoal_tac "(a = action.Accept ∨ a = action.Drop)")
prefer 2
apply(simp_all add: simple_ruleset_def)
apply fastforce
apply(simp add: normalized_src_ports_def2 normalized_dst_ports_def2 normalized_src_ips_def2 normalized_dst_ips_def2)
apply(intro conjI)
by fastforce+
} note 1=this
from 1 show "simple_ruleset (lower_closure rs)"
apply(simp add: simple_ruleset_def)
apply(clarify)
apply(rename_tac r)
apply(case_tac r)
apply(simp)
by blast
from 1 show "∀ r ∈ set (lower_closure rs). normalized_nnf_match (get_match r) ∧
normalized_src_ports (get_match r) ∧
normalized_dst_ports (get_match r) ∧
normalized_src_ips (get_match r) ∧
normalized_dst_ips (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r) ∧
¬ has_disc is_Extra (get_match r)"
apply(clarify)
apply(rename_tac r)
apply(case_tac r)
apply(simp)
done
show "∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Dst_Ports a) ⟹ ∀a. ¬ disc (Src a) ⟹ ∀a. ¬ disc (Dst a) ⟹
∀a. ¬ disc (IIface a) ∨ disc = is_Iiface ⟹ ∀a. ¬ disc (OIface a) ∨ disc = is_Oiface ⟹
∀a. ¬ disc (Prot a) ⟹
∀ r ∈ set rs. ¬ has_disc disc (get_match r) ⟹ ∀ r ∈ set (lower_closure rs). ¬ has_disc disc (get_match r)"
using simplers
unfolding lower_closure_def
apply -
apply(frule(1) transform_remove_unknowns_lower(3)[where disc=disc])
apply(drule transform_remove_unknowns_lower(2))
apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_deny, where disc=disc])
apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_deny])
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
apply(frule(1) transform_normalize_primitives(3)[OF _ wf_in_doubt_deny, of _ disc])
apply(simp;fail)
apply blast
apply(simp;fail)
apply(simp;fail)
apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_deny], simp)
apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_deny, where disc=disc])
apply(simp add: remdups_rev_set)
done
have no_ports_1:
"¬ has_disc_negated is_Src_Ports False (get_match m) ∧
¬ has_disc_negated is_Dst_Ports False (get_match m) ∧
¬ has_disc is_MultiportPorts (get_match m)"
if no_ports: "∀r∈set rs.
¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
and m: "m ∈ set (transform_optimize_dnf_strict (optimize_matches_a lower_closure_matchexpr rs))"
for m
proof -
from no_ports transform_remove_unknowns_lower(3,6)[OF simplers] have
"∀r∈ set (optimize_matches_a lower_closure_matchexpr rs).
¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
by blast
from m this transform_optimize_dnf_strict_structure(2,5)[OF optimize_matches_a_simple_ruleset[OF simplers] wf_in_doubt_deny, of lower_closure_matchexpr]
show ?thesis by blast
qed
show"∀a. ¬ disc (Src_Ports a) ⟹ ∀a. ¬ disc (Dst_Ports a) ⟹ ∀a. ¬ disc (Src a) ⟹ ∀a. ¬ disc (Dst a) ⟹
∀a. ¬ disc (IIface a) ∨ disc = is_Iiface ⟹ ∀a. ¬ disc (OIface a) ∨ disc = is_Oiface ⟹
(∀a. ¬ disc (Prot a)) ∨ disc = is_Prot ∧
(∀ r ∈ set rs. ¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)) ⟹
∀ r ∈ set rs. ¬ has_disc_negated disc False (get_match r) ⟹
∀ r ∈ set (lower_closure rs). ¬ has_disc_negated disc False (get_match r)"
using simplers
unfolding lower_closure_def
apply -
apply(frule(1) transform_remove_unknowns_lower(6)[where disc=disc])
apply(drule transform_remove_unknowns_lower(2))
apply(frule(1) transform_optimize_dnf_strict_structure(5)[OF _ wf_in_doubt_deny, where disc=disc])
apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_deny])
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
apply(frule(1) transform_normalize_primitives(7)[OF _ wf_in_doubt_deny, of _ disc])
apply(simp;fail)
apply blast
apply(elim disjE)
apply blast
apply(simp)
using no_ports_1 apply fast
apply(simp;fail)
apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_deny], simp)
apply(frule(1) transform_optimize_dnf_strict_structure(5)[OF _ wf_in_doubt_deny, where disc=disc])
apply(simp add: remdups_rev_set)
done
show "(common_matcher, in_doubt_deny),p⊢ ⟨lower_closure rs, s⟩ ⇒⇩α t ⟷ (common_matcher, in_doubt_deny),p⊢ ⟨rs, s⟩ ⇒⇩α t"
using simplers
unfolding lower_closure_def
apply -
apply(frule transform_remove_unknowns_lower(1)[where p=p and s=s and t=t])
apply(drule transform_remove_unknowns_lower(2))
apply(frule transform_optimize_dnf_strict[OF _ wf_in_doubt_deny, where p=p and s=s and t=t])
apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_deny])
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
apply(frule(1) transform_normalize_primitives(1)[OF _ wf_in_doubt_deny, where p=p and s=s and t=t])
apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_deny], simp)
apply(frule transform_optimize_dnf_strict[OF _ wf_in_doubt_deny, where p=p and s=s and t=t])
apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
apply(simp)
using approximating_bigstep_fun_remdups_rev
by (simp add: approximating_bigstep_fun_remdups_rev approximating_semantics_iff_fun_good_ruleset remdups_rev_simplers simple_imp_good_ruleset)
qed
definition iface_try_rewrite
:: "(iface × ('i::len word × nat) list) list
⇒ 'i prefix_routing option
⇒ 'i common_primitive rule list
⇒ 'i common_primitive rule list"
where
"iface_try_rewrite ipassmt rtblo rs ≡
let o_rewrite = (case rtblo of None ⇒ id | Some rtbl ⇒
transform_optimize_dnf_strict ∘ optimize_matches (oiface_rewrite (map_of_ipassmt (routing_ipassmt rtbl)))) in
if ipassmt_sanity_disjoint (map_of ipassmt) ∧ ipassmt_sanity_defined rs (map_of ipassmt) then
optimize_matches (iiface_rewrite (map_of_ipassmt ipassmt)) (o_rewrite rs)
else
optimize_matches (iiface_constrain (map_of_ipassmt ipassmt)) (o_rewrite rs)"
text‹Where @{typ "(iface × ('i::len word × nat) list) list"} is @{const map_of}@{typ "'i::len ipassignment"}.
The sanity checkers need to iterate over the interfaces, hence we don't pass a map but a list of tuples.›
text‹In @{file ‹Transform.thy›} there should be the final correctness theorem for ‹iface_try_rewrite›.
Here are some structural properties.›
lemma iface_try_rewrite_simplers: "simple_ruleset rs ⟹ simple_ruleset (iface_try_rewrite ipassmt rtblo rs)"
by(simp add: iface_try_rewrite_def optimize_matches_simple_ruleset transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow
] Let_def split: option.splits)
lemma iiface_rewrite_preserves_nodisc:
"∀a. ¬ disc (Src a) ⟹ ¬ has_disc disc m ⟹ ¬ has_disc disc (iiface_rewrite ipassmt m)"
proof(induction ipassmt m rule: iiface_rewrite.induct)
case 2
have "∀a. ¬ disc (Src a) ⟹ ¬ disc (IIface ifce) ⟹ ¬ has_disc disc (ipassmt_iface_replace_srcip_mexpr ipassmt ifce)"
for ifce ipassmt
apply(simp add: ipassmt_iface_replace_srcip_mexpr_def split: option.split)
apply(intro allI impI, rename_tac ips)
apply(drule_tac X=Src and ls="map (uncurry IpAddrNetmask) ips" in match_list_to_match_expr_not_has_disc)
apply(simp)
done
with 2 show ?case by simp
qed(simp_all)
lemma iiface_constrain_preserves_nodisc:
"∀a. ¬ disc (Src a) ⟹ ¬ has_disc disc m ⟹ ¬ has_disc disc (iiface_constrain ipassmt m)"
proof(induction ipassmt m rule: iiface_rewrite.induct)
case 2
have "∀a. ¬ disc (Src a) ⟹ ¬ disc (IIface ifce) ⟹ ¬ has_disc disc (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce)"
for ifce ipassmt
apply(simp add: ipassmt_iface_constrain_srcip_mexpr_def split: option.split)
apply(intro allI impI, rename_tac ips)
apply(drule_tac X=Src and ls="map (uncurry IpAddrNetmask) ips" in match_list_to_match_expr_not_has_disc)
apply(simp)
done
with 2 show ?case by simp
qed(simp_all)
lemma iface_try_rewrite_preserves_nodisc: "
simple_ruleset rs ⟹
∀a. ¬ disc (Src a) ⟹ ∀a. ¬ disc (Dst a) ⟹
∀r∈ set rs. ¬ has_disc disc (get_match r) ⟹
∀r∈ set (iface_try_rewrite ipassmt rtblo rs). ¬ has_disc disc (get_match r)"
apply(insert wf_in_doubt_deny)
apply(simp add: iface_try_rewrite_def Let_def)
apply(intro conjI impI optimize_matches_preserves)
apply(case_tac[!] rtblo)
apply(simp_all add: oiface_rewrite_preserves_nodisc iiface_rewrite_preserves_nodisc iiface_constrain_preserves_nodisc)
apply(rule iiface_rewrite_preserves_nodisc; assumption?)
apply(rule transform_optimize_dnf_strict_structure(2)[THEN bspec]; (assumption|simp add: optimize_matches_simple_ruleset; fail)?)
apply(rule optimize_matches_preserves)
apply(rule oiface_rewrite_preserves_nodisc; simp; fail)
apply(rule iiface_constrain_preserves_nodisc; assumption?)
apply(rule transform_optimize_dnf_strict_structure(2)[THEN bspec]; (assumption|simp add: optimize_matches_simple_ruleset; fail)?)
apply(rule optimize_matches_preserves)
apply(rule oiface_rewrite_preserves_nodisc; simp; fail)
done
theorem iface_try_rewrite_no_rtbl:
assumes simplers: "simple_ruleset rs"
and normalized: "∀ r ∈ set rs. normalized_nnf_match (get_match r)"
and wf_ipassmt1: "ipassmt_sanity_nowildcards (map_of ipassmt)" and wf_ipassmt2: "distinct (map fst ipassmt)"
and nospoofing: "∃ips. (map_of ipassmt) (Iface (p_iiface p)) = Some ips ∧ p_src p ∈ ipcidr_union_set (set ips)"
shows "(common_matcher, α),p⊢ ⟨iface_try_rewrite ipassmt None rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
proof -
show "(common_matcher, α),p⊢ ⟨iface_try_rewrite ipassmt None rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
apply(simp add: iface_try_rewrite_def Let_def comp_def)
apply(simp add: map_of_ipassmt_def wf_ipassmt1 wf_ipassmt2)
apply(intro conjI impI)
apply(elim conjE)
using iiface_rewrite(1)[OF simplers normalized wf_ipassmt1 _ nospoofing] apply blast
using iiface_constrain(1)[OF simplers normalized wf_ipassmt1, where p = p] nospoofing apply force
done
qed
lemma optimize_matches_comp:
assumes mono: "⋀m. matcheq_matchNone m ⟹ matcheq_matchNone (g m)"
shows "optimize_matches (g ∘ f) rs = optimize_matches g ((optimize_matches f) rs)"
unfolding optimize_matches_def
proof(induction rs)
case (Cons r rs)
obtain m a where [simp]: "r = Rule m a" by(cases r)
show ?case
proof(cases "matcheq_matchNone (f m)")
case True
hence mn: "matcheq_matchNone (g (f m))" by(fact mono)
show ?thesis by(unfold comp_def ; simp add: mn Cons.IH[unfolded comp_def])
next
case False
show ?thesis by(unfold comp_def; simp add: False Cons.IH[unfolded comp_def])
qed
qed simp
context begin
private lemma iiface_rewrite_monoNone: "matcheq_matchNone m ⟹ matcheq_matchNone (iiface_rewrite ipassmt m)"
by(induction m rule: matcheq_matchNone.induct) auto
private lemma iiface_constrain_monoNone: "matcheq_matchNone m ⟹ matcheq_matchNone (iiface_constrain ipassmt m)"
by(induction m rule: matcheq_matchNone.induct) auto
private lemmas optimize_matches_iiface_comp = optimize_matches_comp[OF iiface_rewrite_monoNone]
optimize_matches_comp[OF iiface_constrain_monoNone]
end
theorem iface_try_rewrite_rtbl:
assumes simplers: "simple_ruleset rs"
and normalized: "∀ r ∈ set rs. normalized_nnf_match (get_match r)"
and wf_ipassmt: "ipassmt_sanity_nowildcards (map_of ipassmt)" "distinct (map fst ipassmt)"
and nospoofing: "∃ips. (map_of ipassmt) (Iface (p_iiface p)) = Some ips ∧ p_src p ∈ ipcidr_union_set (set ips)"
and routing_decided: "output_iface (routing_table_semantics rtbl (p_dst p)) = p_oiface p"
and correct_routing: "correct_routing rtbl"
and wf_ipassmt_o: "ipassmt_sanity_nowildcards (map_of (routing_ipassmt rtbl))"
and wf_match_tac: "wf_unknown_match_tac α"
shows "(common_matcher, α),p⊢ ⟨iface_try_rewrite ipassmt (Some rtbl) rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
proof -
note oiface_rewrite = oiface_rewrite[OF simplers normalized wf_ipassmt_o refl correct_routing routing_decided]
let ?ors = "optimize_matches (oiface_rewrite (map_of (routing_ipassmt rtbl))) rs"
let ?nrs = "transform_optimize_dnf_strict ?ors"
have osimplers: "simple_ruleset ?ors" using oiface_rewrite(2) .
have nsimplers: "simple_ruleset ?nrs" using transform_optimize_dnf_strict_structure(1)[OF osimplers wf_match_tac] .
have nnormalized: "∀ r ∈ set ?nrs. normalized_nnf_match (get_match r)" using transform_optimize_dnf_strict_structure(3)[OF osimplers wf_match_tac] .
note nnf = transform_optimize_dnf_strict[OF osimplers wf_match_tac]
have nospoofing_alt: "⋀ips. map_of ipassmt (Iface (p_iiface p)) = Some ips ⟹ p_src p ∈ ipcidr_union_set (set ips)" using nospoofing by simp
show "(common_matcher, α),p⊢ ⟨iface_try_rewrite ipassmt (Some rtbl) rs, s⟩ ⇒⇩α t ⟷ (common_matcher, α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
apply(simp add: iface_try_rewrite_def Let_def)
apply(simp add: map_of_ipassmt_def wf_ipassmt routing_ipassmt_distinct wf_ipassmt_o)
apply(intro conjI impI; (elim conjE)?)
subgoal using iiface_rewrite(1)[OF nsimplers nnormalized wf_ipassmt(1) _ nospoofing] oiface_rewrite(1) nnf by simp
subgoal using iiface_constrain(1)[OF nsimplers nnormalized wf_ipassmt(1), where p = p] nospoofing_alt oiface_rewrite(1) nnf by simp
done
qed
end
Theory Primitive_Abstract
theory Primitive_Abstract
imports
Common_Primitive_toString
Transform
Conntrack_State_Transform
begin
section‹Abstracting over Primitives›
text‹Abstract over certain primitives. The first parameter is a function
@{typ "'i::len common_primitive negation_type ⇒ bool"} to select the primitives to be abstracted over.
The @{typ "'i::len common_primitive"} is wrapped in a @{typ "'i::len common_primitive negation_type"} to let the function
selectively abstract only over negated, non-negated, or both kinds of primitives.
This functions requires a @{const normalized_nnf_match}.
›
fun abstract_primitive
:: "('i::len common_primitive negation_type ⇒ bool) ⇒ 'i common_primitive match_expr ⇒ 'i common_primitive match_expr"
where
"abstract_primitive _ MatchAny = MatchAny" |
"abstract_primitive disc (Match a) =
(if
disc (Pos a)
then
Match (Extra (common_primitive_toString ipaddr_generic_toString a))
else
(Match a))" |
"abstract_primitive disc (MatchNot (Match a)) =
(if
disc (Neg a)
then
Match (Extra (''! ''@common_primitive_toString ipaddr_generic_toString a))
else
(MatchNot (Match a)))" |
"abstract_primitive disc (MatchNot m) = MatchNot (abstract_primitive disc m)" |
"abstract_primitive disc (MatchAnd m1 m2) = MatchAnd (abstract_primitive disc m1) (abstract_primitive disc m2)"
text‹For example, a simple firewall requires that no negated interfaces and protocols occur in the
expression.›
definition abstract_for_simple_firewall :: "'i::len common_primitive match_expr ⇒ 'i common_primitive match_expr"
where "abstract_for_simple_firewall ≡ abstract_primitive (λr. case r
of Pos a ⇒ is_CT_State a ∨ is_L4_Flags a
| Neg a ⇒ is_Iiface a ∨ is_Oiface a ∨ is_Prot a ∨ is_CT_State a ∨ is_L4_Flags a)"
lemma abstract_primitive_preserves_normalized:
"normalized_src_ports m ⟹ normalized_src_ports (abstract_primitive disc m)"
"normalized_dst_ports m ⟹ normalized_dst_ports (abstract_primitive disc m)"
"normalized_src_ips m ⟹ normalized_src_ips (abstract_primitive disc m)"
"normalized_dst_ips m ⟹ normalized_dst_ips (abstract_primitive disc m)"
"normalized_nnf_match m ⟹ normalized_nnf_match (abstract_primitive disc m)"
by(induction disc m rule: abstract_primitive.induct) (simp_all)
lemma abstract_primitive_preserves_nodisc:
"¬ has_disc disc' m ⟹ (∀str. ¬ disc' (Extra str)) ⟹ ¬ has_disc disc' (abstract_primitive disc m)"
by(induction disc m rule: abstract_primitive.induct)(simp_all)
lemma abstract_primitive_preserves_nodisc_nedgated:
"¬ has_disc_negated disc' neg m ⟹ (∀str. ¬ disc' (Extra str)) ⟹ ¬ has_disc_negated disc' neg (abstract_primitive disc m)"
by(induction disc m arbitrary: neg rule: abstract_primitive.induct) simp+
lemma abstract_primitive_nodisc:
"∀x. disc' x ⟶ disc (Pos x) ∧ disc (Neg x) ⟹ (∀str. ¬ disc' (Extra str)) ⟹ ¬ has_disc disc' (abstract_primitive disc m)"
by(induction disc m rule: abstract_primitive.induct) auto
lemma abstract_primitive_preserves_not_has_disc_negated:
"∀a. ¬ disc (Extra a)⟹ ¬ has_disc_negated disc neg m ⟹ ¬ has_disc_negated disc neg (abstract_primitive sel_f m)"
by(induction sel_f m arbitrary: neg rule: abstract_primitive.induct) simp+
lemma abstract_for_simple_firewall_preserves_nodisc_negated:
"∀a. ¬ disc (Extra a)⟹ ¬ has_disc_negated disc False m ⟹ ¬ has_disc_negated disc False (abstract_for_simple_firewall m)"
unfolding abstract_for_simple_firewall_def
using abstract_primitive_preserves_nodisc_nedgated by blast
text‹The function @{const ctstate_assume_state} can be used to fix a state and hence remove all state matches from the ruleset.
It is therefore advisable to create a simple firewall for a fixed state, e.g. with @{const ctstate_assume_new} before
calling to @{const abstract_for_simple_firewall}.›
lemma not_hasdisc_ctstate_assume_state: "¬ has_disc is_CT_State (ctstate_assume_state s m)"
by(induction m rule: ctstate_assume_state.induct) (simp_all)
lemma abstract_for_simple_firewall_hasdisc: fixes m :: "'i::len common_primitive match_expr"
shows "¬ has_disc is_CT_State (abstract_for_simple_firewall m)"
and "¬ has_disc is_L4_Flags (abstract_for_simple_firewall m)"
unfolding abstract_for_simple_firewall_def
apply(induction "(λr:: 'i common_primitive negation_type. case r of Pos a ⇒ is_CT_State a | Neg a ⇒ is_Iiface a ∨ is_Oiface a ∨ is_Prot a ∨ is_CT_State a)" m rule: abstract_primitive.induct)
apply(simp_all)
done
lemma abstract_for_simple_firewall_negated_ifaces_prots: fixes m :: "'i::len common_primitive match_expr"
shows "normalized_nnf_match m ⟹ ¬ has_disc_negated (λa. is_Iiface a ∨ is_Oiface a) False (abstract_for_simple_firewall m)"
and "normalized_nnf_match m ⟹ ¬ has_disc_negated is_Prot False (abstract_for_simple_firewall m)"
unfolding abstract_for_simple_firewall_def
apply(induction "(λr:: 'i common_primitive negation_type. case r of Pos a ⇒ is_CT_State a | Neg a ⇒ is_Iiface a ∨ is_Oiface a ∨ is_Prot a ∨ is_CT_State a)" m rule: abstract_primitive.induct)
apply(simp_all)
done
context
begin
private lemma abstract_primitive_in_doubt_allow_Allow:
"primitive_matcher_generic β ⟹ normalized_nnf_match m ⟹
matches (β, in_doubt_allow) m action.Accept p ⟹
matches (β, in_doubt_allow) (abstract_primitive disc m) action.Accept p"
by(induction disc m rule: abstract_primitive.induct)
(simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)
private lemma abstract_primitive_in_doubt_allow_Allow2:
"primitive_matcher_generic β ⟹ normalized_nnf_match m ⟹
¬ matches (β, in_doubt_allow) m action.Drop p ⟹
¬ matches (β, in_doubt_allow) (abstract_primitive disc m) action.Drop p"
proof(induction disc m rule: abstract_primitive.induct)
case(5 m1 m2) thus ?case by (auto simp add: bunch_of_lemmata_about_matches(1))
qed(simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)
private lemma abstract_primitive_in_doubt_allow_Deny:
"primitive_matcher_generic β ⟹ normalized_nnf_match m ⟹
matches (β, in_doubt_allow) (abstract_primitive disc m) action.Drop p ⟹
matches (β, in_doubt_allow) m action.Drop p"
apply(induction disc m rule: abstract_primitive.induct)
apply (simp_all add: bunch_of_lemmata_about_matches(1))
apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
done
private lemma abstract_primitive_in_doubt_allow_Deny2:
"primitive_matcher_generic β ⟹ normalized_nnf_match m ⟹
¬ matches (β, in_doubt_allow) (abstract_primitive disc m) action.Accept p ⟹
¬ matches (β, in_doubt_allow) m action.Accept p"
apply(induction disc m rule: abstract_primitive.induct)
apply (simp_all add: bunch_of_lemmata_about_matches(1))
apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
done
theorem abstract_primitive_in_doubt_allow_generic:
fixes β::"('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac"
assumes generic: "primitive_matcher_generic β"
and n: "∀ r ∈ set rs. normalized_nnf_match (get_match r)"
and simple: "simple_ruleset rs"
defines "γ ≡ (β, in_doubt_allow)" and "abstract disc ≡ optimize_matches (abstract_primitive disc)"
shows "{p. γ,p⊢ ⟨abstract disc rs, Undecided⟩ ⇒⇩α Decision FinalDeny} ⊆ {p. γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalDeny}"
(is ?deny)
and "{p. γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow} ⊆ {p. γ,p⊢ ⟨abstract disc rs, Undecided⟩ ⇒⇩α Decision FinalAllow}"
(is ?allow)
proof -
from simple have "good_ruleset rs" using simple_imp_good_ruleset by fast
from optimize_matches_simple_ruleset simple simple_imp_good_ruleset have
good: "good_ruleset (optimize_matches (abstract_primitive disc) rs)" by fast
let ?γ="(β, in_doubt_allow) :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
have abstract_primitive_in_doubt_allow_help1:
"approximating_bigstep_fun γ p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalAllow"
if prem: "approximating_bigstep_fun γ p rs Undecided = Decision FinalAllow" for p
proof -
from simple have "wf_ruleset γ p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
from this simple prem n show ?thesis
unfolding γ_def
proof(induction ?γ p rs Undecided rule: approximating_bigstep_fun_induct_wf)
case (MatchAccept p m a rs)
from MatchAccept.prems
abstract_primitive_in_doubt_allow_Allow[OF generic] MatchAccept.hyps have
"matches ?γ (abstract_primitive disc m) action.Accept p" by simp
thus ?case
apply(simp add: MatchAccept.hyps(2))
using optimize_matches_matches_fst by fastforce
next
case (Nomatch p m a rs) thus ?case
proof(cases "matches ?γ (abstract_primitive disc m) a p")
case False with Nomatch show ?thesis
apply(simp add: optimize_matches_def)
using simple_ruleset_tail by blast
next
case True
from Nomatch.prems(1) have "a = action.Accept ∨ a = action.Drop" by(simp add: simple_ruleset_def)
from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_allow_Allow2[OF generic] have
"a = action.Drop ⟹ ¬ matches ?γ (abstract_primitive disc m) action.Drop p" by simp
with True ‹a = action.Accept ∨ a = action.Drop› have "a = action.Accept" by blast
with True show ?thesis
using optimize_matches_matches_fst by fastforce
qed
qed(simp_all add: simple_ruleset_def)
qed
have abstract_primitive_in_doubt_allow_help2:
"approximating_bigstep_fun γ p rs Undecided = Decision FinalDeny"
if prem: "approximating_bigstep_fun γ p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalDeny"
for p
proof -
from simple have "wf_ruleset γ p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
from this simple prem n show ?thesis
unfolding γ_def
proof(induction ?γ p rs Undecided rule: approximating_bigstep_fun_induct_wf)
case Empty thus ?case by(simp add: optimize_matches_def)
next
case (MatchAccept p m a rs)
from MatchAccept.prems abstract_primitive_in_doubt_allow_Allow[OF generic] MatchAccept.hyps have
1: "matches ?γ (abstract_primitive disc m) action.Accept p" by simp
with MatchAccept have "approximating_bigstep_fun ?γ p
(Rule (abstract_primitive disc m) action.Accept # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalDeny"
using optimize_matches_matches_fst by metis
with 1 have False by(simp)
thus ?case ..
next
case (Nomatch p m a rs) thus ?case
proof(cases "matches ?γ (abstract_primitive disc m) a p")
case False
with Nomatch.prems(2) have "approximating_bigstep_fun ?γ p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalDeny"
by(simp add: optimize_matches_def split: if_split_asm)
with Nomatch have IH: "approximating_bigstep_fun ?γ p rs Undecided = Decision FinalDeny"
using simple_ruleset_tail by auto
with Nomatch(1) show ?thesis by simp
next
case True
from Nomatch.prems(2) True have 1: "approximating_bigstep_fun ?γ p
(Rule (abstract_primitive disc m) a # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalDeny"
using optimize_matches_matches_fst by metis
from Nomatch.prems(1) have "a = action.Accept ∨ a = action.Drop" by(simp add: simple_ruleset_def)
from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_allow_Allow2[OF generic] have
"a = action.Drop ⟹ ¬ matches ?γ (abstract_primitive disc m) action.Drop p" by simp
with True ‹a = action.Accept ∨ a = action.Drop› have "a = action.Accept" by blast
with 1 True have False by simp
thus ?thesis ..
qed
qed(simp_all add: simple_ruleset_def)
qed
from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_allow_help1 ‹good_ruleset rs› show ?allow
unfolding abstract_def by fast
from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_allow_help2 ‹good_ruleset rs› γ_def show ?deny
unfolding abstract_def by fast
qed
corollary abstract_primitive_in_doubt_allow:
assumes "∀ r ∈ set rs. normalized_nnf_match (get_match r)" and "simple_ruleset rs"
defines "γ ≡ (common_matcher, in_doubt_allow)" and "abstract disc ≡ optimize_matches (abstract_primitive disc)"
shows "{p. γ,p⊢ ⟨abstract disc rs, Undecided⟩ ⇒⇩α Decision FinalDeny} ⊆ {p. γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalDeny}"
and "{p. γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow} ⊆ {p. γ,p⊢ ⟨abstract disc rs, Undecided⟩ ⇒⇩α Decision FinalAllow}"
unfolding γ_def abstract_def
using assms abstract_primitive_in_doubt_allow_generic[OF primitive_matcher_generic_common_matcher] by blast+
end
context
begin
private lemma abstract_primitive_in_doubt_deny_Deny:
"primitive_matcher_generic β ⟹ normalized_nnf_match m ⟹
matches (β, in_doubt_deny) m action.Drop p ⟹
matches (β, in_doubt_deny) (abstract_primitive disc m) action.Drop p"
by(induction disc m rule: abstract_primitive.induct)
(simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)
private lemma abstract_primitive_in_doubt_deny_Deny2:
"primitive_matcher_generic β ⟹ normalized_nnf_match m ⟹
¬ matches (β, in_doubt_deny) m action.Accept p ⟹
¬ matches (β, in_doubt_deny) (abstract_primitive disc m) action.Accept p"
proof(induction disc m rule: abstract_primitive.induct)
case(5 m1 m2) thus ?case by (auto simp add: bunch_of_lemmata_about_matches(1))
qed(simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)
private lemma abstract_primitive_in_doubt_deny_Allow:
"primitive_matcher_generic β ⟹ normalized_nnf_match m ⟹
matches (β, in_doubt_deny) (abstract_primitive disc m) action.Accept p ⟹
matches (β, in_doubt_deny) m action.Accept p"
apply(induction disc m rule: abstract_primitive.induct)
apply (simp_all add: bunch_of_lemmata_about_matches(1))
apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
done
private lemma abstract_primitive_in_doubt_deny_Allow2:
"primitive_matcher_generic β ⟹ normalized_nnf_match m ⟹
¬ matches (β, in_doubt_deny) (abstract_primitive disc m) action.Drop p ⟹
¬ matches (β, in_doubt_deny) m action.Drop p"
apply(induction disc m rule: abstract_primitive.induct)
apply (simp_all add: bunch_of_lemmata_about_matches(1))
apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
done
theorem abstract_primitive_in_doubt_deny_generic:
fixes β::"('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac"
assumes generic: "primitive_matcher_generic β"
and n: "∀ r ∈ set rs. normalized_nnf_match (get_match r)"
and simple: "simple_ruleset rs"
defines "γ ≡ (β, in_doubt_deny)" and "abstract disc ≡ optimize_matches (abstract_primitive disc)"
shows "{p. γ,p⊢ ⟨abstract disc rs, Undecided⟩ ⇒⇩α Decision FinalAllow} ⊆ {p. γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow}"
(is ?allow)
and "{p. γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalDeny} ⊆ {p. γ,p⊢ ⟨abstract disc rs, Undecided⟩ ⇒⇩α Decision FinalDeny}"
(is ?deny)
proof -
from simple have "good_ruleset rs" using simple_imp_good_ruleset by fast
from optimize_matches_simple_ruleset simple simple_imp_good_ruleset have
good: "good_ruleset (optimize_matches (abstract_primitive disc) rs)" by fast
let ?γ="(β, in_doubt_deny) :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
have abstract_primitive_in_doubt_deny_help1:
"approximating_bigstep_fun γ p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalDeny"
if prem: "approximating_bigstep_fun γ p rs Undecided = Decision FinalDeny" for p
proof -
from simple have "wf_ruleset γ p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
from this simple prem n show ?thesis
unfolding γ_def
proof(induction ?γ p rs Undecided rule: approximating_bigstep_fun_induct_wf)
case (MatchDrop p m a rs)
from MatchDrop.prems abstract_primitive_in_doubt_deny_Deny[OF generic] MatchDrop.hyps have
"matches ?γ (abstract_primitive disc m) action.Drop p" by simp
thus ?case
apply(simp add: MatchDrop.hyps(2))
using optimize_matches_matches_fst by fastforce
next
case (Nomatch p m a rs) thus ?case
proof(cases "matches ?γ (abstract_primitive disc m) a p")
case False with Nomatch show ?thesis
apply(simp add: optimize_matches_def)
using simple_ruleset_tail by blast
next
case True
from Nomatch.prems(1) have "a = action.Accept ∨ a = action.Drop" by(simp add: simple_ruleset_def)
from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_deny_Deny2[OF generic] have
"a = action.Accept ⟹ ¬ matches ?γ (abstract_primitive disc m) action.Accept p" by(simp)
with True ‹a = action.Accept ∨ a = action.Drop› have "a = action.Drop" by blast
with True show ?thesis using optimize_matches_matches_fst by fastforce
qed
qed(simp_all add: simple_ruleset_def)
qed
have abstract_primitive_in_doubt_deny_help2:
"approximating_bigstep_fun γ p rs Undecided = Decision FinalAllow"
if prem: "approximating_bigstep_fun γ p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalAllow"
for p
proof -
from simple have "wf_ruleset ?γ p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
from this simple prem n show ?thesis
unfolding γ_def
proof(induction ?γ p rs Undecided rule: approximating_bigstep_fun_induct_wf)
case Empty thus ?case by(simp add: optimize_matches_def)
next
case (MatchAccept p m a rs) thus ?case by auto
next
case (MatchDrop p m a rs)
from MatchDrop.prems abstract_primitive_in_doubt_deny_Deny[OF generic] MatchDrop.hyps have
1: "matches ?γ (abstract_primitive disc m) action.Drop p" by simp
from MatchDrop have "approximating_bigstep_fun ?γ p
(Rule (abstract_primitive disc m) action.Drop # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalAllow"
using optimize_matches_matches_fst 1 by fastforce
with 1 have False by(simp)
thus ?case ..
next
case (Nomatch p m a rs) thus ?case
proof(cases "matches ?γ (abstract_primitive disc m) a p")
case False
with Nomatch.prems(2) have "approximating_bigstep_fun ?γ p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalAllow"
by(simp add: optimize_matches_def split: if_split_asm)
with Nomatch have IH: "approximating_bigstep_fun ?γ p rs Undecided = Decision FinalAllow"
using simple_ruleset_tail by auto
with Nomatch(1) show ?thesis by simp
next
case True
from Nomatch.prems(2) True have 1: "approximating_bigstep_fun ?γ p
(Rule (abstract_primitive disc m) a # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalAllow"
using optimize_matches_matches_fst by metis
from Nomatch.prems(1) have "a = action.Accept ∨ a = action.Drop" by(simp add: simple_ruleset_def)
from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_deny_Deny2[OF generic] have
"a = action.Accept ⟹ ¬ matches ?γ (abstract_primitive disc m) action.Accept p" by simp
with True ‹a = action.Accept ∨ a = action.Drop› have "a = action.Drop" by blast
with 1 True have False by force
thus ?thesis ..
qed
qed(simp_all add: simple_ruleset_def)
qed
from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_deny_help1 ‹good_ruleset rs› show ?deny
unfolding abstract_def by fast
from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_deny_help2 ‹good_ruleset rs› show ?allow
unfolding abstract_def by fast
qed
end
end
Theory SimpleFw_Compliance
section‹Iptables to Simple Firewall and Vice Versa›
theory SimpleFw_Compliance
imports Simple_Firewall.SimpleFw_Semantics
"../Primitive_Matchers/Transform"
"../Primitive_Matchers/Primitive_Abstract"
begin
subsection‹Simple Match to MatchExpr›
fun simple_match_to_ipportiface_match :: "'i::len simple_match ⇒ 'i common_primitive match_expr" where
"simple_match_to_ipportiface_match ⦇iiface=iif, oiface=oif, src=sip, dst=dip, proto=p, sports=sps, dports=dps ⦈ =
MatchAnd (Match (IIface iif)) (MatchAnd (Match (OIface oif))
(MatchAnd (Match (Src (uncurry IpAddrNetmask sip)))
(MatchAnd (Match (Dst (uncurry IpAddrNetmask dip)))
(case p of ProtoAny ⇒ MatchAny
| Proto prim_p ⇒
(MatchAnd (Match (Prot p))
(MatchAnd (Match (Src_Ports (L4Ports prim_p [sps])))
(Match (Dst_Ports (L4Ports prim_p [dps])))
))
))))"
lemma ports_to_set_singleton_simple_match_port: "p ∈ ports_to_set [a] ⟷ simple_match_port a p"
by(cases a, simp)
theorem simple_match_to_ipportiface_match_correct:
assumes valid: "simple_match_valid sm"
shows "matches (common_matcher, α) (simple_match_to_ipportiface_match sm) a p ⟷ simple_matches sm p"
proof -
obtain iif oif sip dip pro sps dps where
sm: "sm = ⦇iiface = iif, oiface = oif, src = sip, dst = dip, proto = pro, sports = sps, dports = dps⦈" by (cases sm)
{ fix ip
have "p_src p ∈ ipt_iprange_to_set (uncurry IpAddrNetmask ip) ⟷ simple_match_ip ip (p_src p)"
and "p_dst p ∈ ipt_iprange_to_set (uncurry IpAddrNetmask ip) ⟷ simple_match_ip ip (p_dst p)"
by(simp split: uncurry_split)+
} note simple_match_ips=this
{ fix ps
have "p_sport p ∈ ports_to_set [ps] ⟷ simple_match_port ps (p_sport p)"
and "p_dport p ∈ ports_to_set [ps] ⟷ simple_match_port ps (p_dport p)"
apply(case_tac [!] ps)
by(simp_all)
} note simple_match_ports=this
from valid sm have valid':"pro = ProtoAny ⟹ simple_match_port sps (p_sport p) ∧ simple_match_port dps (p_dport p)"
apply(simp add: simple_match_valid_def)
by blast
show ?thesis unfolding sm
apply(cases pro)
subgoal
apply(simp add: bunch_of_lemmata_about_matches simple_matches.simps)
apply(simp add: match_raw_bool ternary_to_bool_bool_to_ternary simple_match_ips simple_match_ports simple_matches.simps)
using valid' by simp
apply(simp add: bunch_of_lemmata_about_matches simple_matches.simps)
apply(simp add: match_raw_bool ternary_to_bool_bool_to_ternary simple_match_ips simple_match_ports simple_matches.simps)
apply fast
done
qed
subsection‹MatchExpr to Simple Match›
fun common_primitive_match_to_simple_match :: "'i::len common_primitive match_expr ⇒ 'i simple_match option" where
"common_primitive_match_to_simple_match MatchAny = Some (simple_match_any)" |
"common_primitive_match_to_simple_match (MatchNot MatchAny) = None" |
"common_primitive_match_to_simple_match (Match (IIface iif)) = Some (simple_match_any⦇ iiface := iif ⦈)" |
"common_primitive_match_to_simple_match (Match (OIface oif)) = Some (simple_match_any⦇ oiface := oif ⦈)" |
"common_primitive_match_to_simple_match (Match (Src (IpAddrNetmask pre len))) = Some (simple_match_any⦇ src := (pre, len) ⦈)" |
"common_primitive_match_to_simple_match (Match (Dst (IpAddrNetmask pre len))) = Some (simple_match_any⦇ dst := (pre, len) ⦈)" |
"common_primitive_match_to_simple_match (Match (Prot p)) = Some (simple_match_any⦇ proto := p ⦈)" |
"common_primitive_match_to_simple_match (Match (Src_Ports (L4Ports p []))) = None" |
"common_primitive_match_to_simple_match (Match (Src_Ports (L4Ports p [(s,e)]))) = Some (simple_match_any⦇ proto := Proto p, sports := (s,e) ⦈)" |
"common_primitive_match_to_simple_match (Match (Dst_Ports (L4Ports p []))) = None" |
"common_primitive_match_to_simple_match (Match (Dst_Ports (L4Ports p [(s,e)]))) = Some (simple_match_any⦇ proto := Proto p, dports := (s,e) ⦈)" |
"common_primitive_match_to_simple_match (MatchNot (Match (Prot ProtoAny))) = None" |
"common_primitive_match_to_simple_match (MatchAnd m1 m2) = (case (common_primitive_match_to_simple_match m1, common_primitive_match_to_simple_match m2) of
(None, _) ⇒ None
| (_, None) ⇒ None
| (Some m1', Some m2') ⇒ simple_match_and m1' m2')" |
"common_primitive_match_to_simple_match (Match (Src (IpAddr _))) = undefined" |
"common_primitive_match_to_simple_match (Match (Src (IpAddrRange _ _))) = undefined" |
"common_primitive_match_to_simple_match (Match (Dst (IpAddr _))) = undefined" |
"common_primitive_match_to_simple_match (Match (Dst (IpAddrRange _ _))) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (Match (Prot _))) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (Match (IIface _))) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (Match (OIface _))) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (Match (Src _))) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (Match (Dst _))) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (MatchAnd _ _)) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (MatchNot _)) = undefined" |
"common_primitive_match_to_simple_match (Match (Src_Ports _)) = undefined" |
"common_primitive_match_to_simple_match (Match (Dst_Ports _)) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (Match (Src_Ports _))) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (Match (Dst_Ports _))) = undefined" |
"common_primitive_match_to_simple_match (Match (CT_State _)) = undefined" |
"common_primitive_match_to_simple_match (Match (L4_Flags _)) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (Match (L4_Flags _))) = undefined" |
"common_primitive_match_to_simple_match (Match (Extra _)) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (Match (Extra _))) = undefined" |
"common_primitive_match_to_simple_match (MatchNot (Match (CT_State _))) = undefined"
subsubsection‹Normalizing Interfaces›
text‹As for now, negated interfaces are simply not allowed›
definition normalized_ifaces :: "'i::len common_primitive match_expr ⇒ bool" where
"normalized_ifaces m ≡ ¬ has_disc_negated (λa. is_Iiface a ∨ is_Oiface a) False m"
subsubsection‹Normalizing Protocols›
text‹As for now, negated protocols are simply not allowed›
definition normalized_protocols :: "'i::len common_primitive match_expr ⇒ bool" where
"normalized_protocols m ≡ ¬ has_disc_negated is_Prot False m"
lemma match_iface_simple_match_any_simps:
"match_iface (iiface simple_match_any) (p_iiface p)"
"match_iface (oiface simple_match_any) (p_oiface p)"
"simple_match_ip (src simple_match_any) (p_src p)"
"simple_match_ip (dst simple_match_any) (p_dst p)"
"match_proto (proto simple_match_any) (p_proto p)"
"simple_match_port (sports simple_match_any) (p_sport p)"
"simple_match_port (dports simple_match_any) (p_dport p)"
apply (simp_all add: simple_match_any_def match_ifaceAny ipset_from_cidr_0)
apply (subgoal_tac [!] "(65535::16 word) = max_word")
apply (simp_all only:)
apply simp_all
done
theorem common_primitive_match_to_simple_match:
assumes "normalized_src_ports m"
and "normalized_dst_ports m"
and "normalized_src_ips m"
and "normalized_dst_ips m"
and "normalized_ifaces m"
and "normalized_protocols m"
and "¬ has_disc is_L4_Flags m"
and "¬ has_disc is_CT_State m"
and "¬ has_disc is_MultiportPorts m"
and "¬ has_disc is_Extra m"
shows "(Some sm = common_primitive_match_to_simple_match m ⟶ matches (common_matcher, α) m a p ⟷ simple_matches sm p) ∧
(common_primitive_match_to_simple_match m = None ⟶ ¬ matches (common_matcher, α) m a p)"
proof -
show ?thesis
using assms proof(induction m arbitrary: sm rule: common_primitive_match_to_simple_match.induct)
case 1 thus ?case
by(simp add: match_iface_simple_match_any_simps bunch_of_lemmata_about_matches simple_matches.simps)
next
case (9 p s e) thus ?case
apply(simp add: match_iface_simple_match_any_simps simple_matches.simps)
apply(simp add: match_raw_bool ternary_to_bool_bool_to_ternary)
by fastforce
next
case 11 thus ?case
apply(simp add: match_iface_simple_match_any_simps simple_matches.simps)
apply(simp add: match_raw_bool ternary_to_bool_bool_to_ternary)
by fastforce
next
case (13 m1 m2)
let ?caseSome="Some sm = common_primitive_match_to_simple_match (MatchAnd m1 m2)"
let ?caseNone="common_primitive_match_to_simple_match (MatchAnd m1 m2) = None"
let ?goal="(?caseSome ⟶ matches (common_matcher, α) (MatchAnd m1 m2) a p = simple_matches sm p) ∧
(?caseNone ⟶ ¬ matches (common_matcher, α) (MatchAnd m1 m2) a p)"
from 13 have normalized:
"normalized_src_ports m1" "normalized_src_ports m2"
"normalized_dst_ports m1" "normalized_dst_ports m2"
"normalized_src_ips m1" "normalized_src_ips m2"
"normalized_dst_ips m1" "normalized_dst_ips m2"
"normalized_ifaces m1" "normalized_ifaces m2"
"¬ has_disc is_L4_Flags m1" "¬ has_disc is_L4_Flags m2"
"¬ has_disc is_CT_State m1" "¬ has_disc is_CT_State m2"
"¬ has_disc is_MultiportPorts m1" "¬ has_disc is_MultiportPorts m2"
"¬ has_disc is_Extra m1" "¬ has_disc is_Extra m2"
"normalized_protocols m1" "normalized_protocols m2"
by(simp_all add: normalized_protocols_def normalized_ifaces_def)
{ assume caseNone: ?caseNone
{ fix sm1 sm2
assume sm1: "common_primitive_match_to_simple_match m1 = Some sm1"
and sm2: "common_primitive_match_to_simple_match m2 = Some sm2"
and sma: "simple_match_and sm1 sm2 = None"
from sma have 1: "¬ (simple_matches sm1 p ∧ simple_matches sm2 p)" by (simp add: simple_match_and_correct)
from normalized sm1 sm2 "13.IH" have 2: "(matches (common_matcher, α) m1 a p ⟷ simple_matches sm1 p) ∧
(matches (common_matcher, α) m2 a p ⟷ simple_matches sm2 p)" by force
hence 2: "matches (common_matcher, α) (MatchAnd m1 m2) a p ⟷ simple_matches sm1 p ∧ simple_matches sm2 p"
by(simp add: bunch_of_lemmata_about_matches)
from 1 2 have "¬ matches (common_matcher, α) (MatchAnd m1 m2) a p" by blast
}
with caseNone have "common_primitive_match_to_simple_match m1 = None ∨
common_primitive_match_to_simple_match m2 = None ∨
¬ matches (common_matcher, α) (MatchAnd m1 m2) a p"
by(simp split:option.split_asm)
hence "¬ matches (common_matcher, α) (MatchAnd m1 m2) a p"
apply(elim disjE)
apply(simp_all)
using "13.IH" normalized by(simp add: bunch_of_lemmata_about_matches)+
}note caseNone=this
{ assume caseSome: ?caseSome
hence "∃ sm1. common_primitive_match_to_simple_match m1 = Some sm1" and
"∃ sm2. common_primitive_match_to_simple_match m2 = Some sm2"
by(simp_all split: option.split_asm)
from this obtain sm1 sm2 where sm1: "Some sm1 = common_primitive_match_to_simple_match m1"
and sm2: "Some sm2 = common_primitive_match_to_simple_match m2" by fastforce+
with "13.IH" normalized have "matches (common_matcher, α) m1 a p = simple_matches sm1 p ∧
matches (common_matcher, α) m2 a p = simple_matches sm2 p" by simp
hence 1: "matches (common_matcher, α) (MatchAnd m1 m2) a p ⟷ simple_matches sm1 p ∧ simple_matches sm2 p"
by(simp add: bunch_of_lemmata_about_matches)
from caseSome sm1 sm2 have "simple_match_and sm1 sm2 = Some sm" by(simp split: option.split_asm)
hence 2: "simple_matches sm p ⟷ simple_matches sm1 p ∧ simple_matches sm2 p" by(simp add: simple_match_and_correct)
from 1 2 have "matches (common_matcher, α) (MatchAnd m1 m2) a p = simple_matches sm p" by simp
} note caseSome=this
from caseNone caseSome show ?goal by blast
qed(simp_all add: match_iface_simple_match_any_simps simple_matches.simps normalized_protocols_def normalized_ifaces_def,
simp_all add: bunch_of_lemmata_about_matches,
simp_all add: match_raw_bool ternary_to_bool_bool_to_ternary)
qed
lemma simple_fw_remdups_Rev: "simple_fw (remdups_rev rs) p = simple_fw rs p"
apply(induction rs p rule: simple_fw.induct)
apply(simp add: remdups_rev_def)
apply(simp_all add: remdups_rev_fst remdups_rev_removeAll simple_fw_not_matches_removeAll)
done
fun action_to_simple_action :: "action ⇒ simple_action" where
"action_to_simple_action action.Accept = simple_action.Accept" |
"action_to_simple_action action.Drop = simple_action.Drop" |
"action_to_simple_action _ = undefined"
definition check_simple_fw_preconditions :: "'i::len common_primitive rule list ⇒ bool" where
"check_simple_fw_preconditions rs ≡ ∀r ∈ set rs. (case r of (Rule m a) ⇒
normalized_src_ports m ∧
normalized_dst_ports m ∧
normalized_src_ips m ∧
normalized_dst_ips m ∧
normalized_ifaces m ∧
normalized_protocols m ∧
¬ has_disc is_L4_Flags m ∧
¬ has_disc is_CT_State m ∧
¬ has_disc is_MultiportPorts m ∧
¬ has_disc is_Extra m ∧
(a = action.Accept ∨ a = action.Drop))"
lemma "normalized_src_ports m ⟹ normalized_nnf_match m"
apply(induction m rule: normalized_src_ports.induct)
apply(simp_all)[15]
oops
lemma "¬ matcheq_matchNone m ⟹ normalized_src_ports m ⟹ normalized_nnf_match m"
by(induction m rule: normalized_src_ports.induct) (simp_all)
value "check_simple_fw_preconditions [Rule (MatchNot (MatchNot (MatchNot (Match (Src a))))) action.Accept]"
definition to_simple_firewall :: "'i::len common_primitive rule list ⇒ 'i simple_rule list" where
"to_simple_firewall rs ≡ if check_simple_fw_preconditions rs then
List.map_filter (λr. case r of Rule m a ⇒
(case (common_primitive_match_to_simple_match m) of None ⇒ None |
Some sm ⇒ Some (SimpleRule sm (action_to_simple_action a)))) rs
else undefined"
lemma to_simple_firewall_simps:
"to_simple_firewall [] = []"
"check_simple_fw_preconditions ((Rule m a)#rs) ⟹ to_simple_firewall ((Rule m a)#rs) = (case common_primitive_match_to_simple_match m of
None ⇒ to_simple_firewall rs
| Some sm ⇒ (SimpleRule sm (action_to_simple_action a)) # to_simple_firewall rs)"
"¬ check_simple_fw_preconditions rs' ⟹ to_simple_firewall rs' = undefined"
by(auto simp add: to_simple_firewall_def List.map_filter_simps check_simple_fw_preconditions_def split: option.split)
lemma "check_simple_fw_preconditions
[Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
(MatchAnd (Match (Dst_Ports (L4Ports TCP [(0, 65535)])))
(Match (Src_Ports (L4Ports TCP [(0, 65535)])))))
Drop]" by eval
lemma "to_simple_firewall
[Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
(MatchAnd (Match (Dst_Ports (L4Ports TCP [(0, 65535)])))
(Match (Src_Ports (L4Ports TCP [(0, 65535)])))))
Drop] =
[SimpleRule
⦇iiface = Iface ''+'', oiface = Iface ''+'', src = (0x7F000000, 8), dst = (0, 0), proto = Proto 6, sports = (0, 0xFFFF),
dports = (0, 0xFFFF)⦈
simple_action.Drop]" by eval
lemma "check_simple_fw_preconditions [Rule (MatchAnd MatchAny MatchAny) Drop]"
by(simp add: check_simple_fw_preconditions_def normalized_ifaces_def normalized_protocols_def)
lemma "to_simple_firewall [Rule (MatchAnd MatchAny (MatchAny::32 common_primitive match_expr)) Drop] =
[SimpleRule
⦇iiface = Iface ''+'', oiface = Iface ''+'', src = (0, 0), dst = (0, 0), proto = ProtoAny, sports = (0, 0xFFFF),
dports = (0, 0xFFFF)⦈
simple_action.Drop]" by eval
lemma "to_simple_firewall [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8))) Drop] =
[SimpleRule
⦇iiface = Iface ''+'', oiface = Iface ''+'', src = (0x7F000000, 8), dst = (0, 0), proto = ProtoAny, sports = (0, 0xFFFF),
dports = (0, 0xFFFF)⦈
simple_action.Drop]" by eval
theorem to_simple_firewall: "check_simple_fw_preconditions rs ⟹ approximating_bigstep_fun (common_matcher, α) p rs Undecided = simple_fw (to_simple_firewall rs) p"
proof(induction rs)
case Nil thus ?case by(simp add: to_simple_firewall_simps)
next
case (Cons r rs)
from Cons have IH: "approximating_bigstep_fun (common_matcher, α) p rs Undecided = simple_fw (to_simple_firewall rs) p"
by(simp add: check_simple_fw_preconditions_def)
obtain m a where r: "r = Rule m a" by(cases r, simp)
from Cons.prems have "check_simple_fw_preconditions [r]" by(simp add: check_simple_fw_preconditions_def)
with r common_primitive_match_to_simple_match[where p = p]
have match: "⋀ sm. common_primitive_match_to_simple_match m = Some sm ⟹ matches (common_matcher, α) m a p = simple_matches sm p" and
nomatch: "common_primitive_match_to_simple_match m = None ⟹ ¬ matches (common_matcher, α) m a p"
unfolding check_simple_fw_preconditions_def by simp_all
from to_simple_firewall_simps r Cons.prems have to_simple_firewall_simps': "to_simple_firewall (Rule m a # rs) =
(case common_primitive_match_to_simple_match m of None ⇒ to_simple_firewall rs
| Some sm ⇒ SimpleRule sm (action_to_simple_action a) # to_simple_firewall rs)" by simp
from ‹check_simple_fw_preconditions [r]› have "a = action.Accept ∨ a = action.Drop" by(simp add: r check_simple_fw_preconditions_def)
thus ?case
by(auto simp add: r to_simple_firewall_simps' IH match nomatch split: option.split action.split)
qed
lemma ctstate_assume_new_not_has_CT_State:
"r ∈ set (ctstate_assume_new rs) ⟹ ¬ has_disc is_CT_State (get_match r)"
apply(simp add: ctstate_assume_new_def)
apply(induction rs)
apply(simp add: optimize_matches_def; fail)
apply(simp add: optimize_matches_def)
apply(rename_tac r' rs, case_tac r')
apply(safe)
apply(simp add: split:if_split_asm)
apply(elim disjE)
apply(simp_all add: not_hasdisc_ctstate_assume_state split:if_split_asm)
done
text‹The precondition for the simple firewall can be easily fulfilled.
The subset relation is due to abstracting over some primitives (e.g., negated primitives, l4 flags)›
theorem transform_simple_fw_upper:
defines "preprocess rs ≡ upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new rs)))"
and "newpkt p ≡ match_tcp_flags ipt_tcp_syn (p_tcp_flags p) ∧ p_tag_ctstate p = CT_New"
assumes simplers: "simple_ruleset (rs:: 'i::len common_primitive rule list)"
shows "check_simple_fw_preconditions (preprocess rs)"
and "{p. (common_matcher, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow ∧ newpkt p}"
unfolding check_simple_fw_preconditions_def preprocess_def
apply(clarify, rename_tac r, case_tac r, rename_tac m a, simp)
proof -
let ?rs2="upper_closure (packet_assume_new rs)"
let ?rs3="optimize_matches abstract_for_simple_firewall ?rs2"
let ?rs'="upper_closure ?rs3"
let ?γ="(common_matcher, in_doubt_allow)
:: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
let ?fw="λrs p. approximating_bigstep_fun ?γ p rs Undecided"
from packet_assume_new_simple_ruleset[OF simplers] have s1: "simple_ruleset (packet_assume_new rs)" .
from transform_upper_closure(2)[OF s1] have s2: "simple_ruleset ?rs2" .
from s2 have s3: "simple_ruleset ?rs3" by (simp add: optimize_matches_simple_ruleset)
from transform_upper_closure(2)[OF s3] have s4: "simple_ruleset ?rs'" .
from transform_upper_closure(3)[OF s1] have nnf2:
"∀r∈set (upper_closure (packet_assume_new rs)). normalized_nnf_match (get_match r)" by simp
{ fix m a
assume r: "Rule m a ∈ set ?rs'"
from s4 r have a: "(a = action.Accept ∨ a = action.Drop)" by(auto simp add: simple_ruleset_def)
have "r ∈ set (packet_assume_new rs) ⟹ ¬ has_disc is_CT_State (get_match r)" for r
by(simp add: packet_assume_new_def ctstate_assume_new_not_has_CT_State)
with transform_upper_closure(4)[OF s1, where disc=is_CT_State] have
"∀r∈set (upper_closure (packet_assume_new rs)). ¬ has_disc is_CT_State (get_match r)"
by simp
with abstract_primitive_preserves_nodisc[where disc'="is_CT_State"]
have "∀r∈set ?rs3. ¬ has_disc is_CT_State (get_match r)"
apply(intro optimize_matches_preserves)
by(auto simp add: abstract_for_simple_firewall_def)
with transform_upper_closure(4)[OF s3, where disc=is_CT_State] have
"∀r∈set ?rs'. ¬ has_disc is_CT_State (get_match r)" by simp
with r have no_CT: "¬ has_disc is_CT_State m" by fastforce
from abstract_for_simple_firewall_hasdisc have "∀r∈set ?rs3. ¬ has_disc is_L4_Flags (get_match r)"
by(intro optimize_matches_preserves, auto)
with transform_upper_closure(4)[OF s3, where disc=is_L4_Flags] have
"∀r∈set ?rs'. ¬ has_disc is_L4_Flags (get_match r)" by simp
with r have no_L4_Flags: "¬ has_disc is_L4_Flags m" by fastforce
from nnf2 abstract_for_simple_firewall_negated_ifaces_prots have
ifaces: "∀r∈set ?rs3. ¬ has_disc_negated (λa. is_Iiface a ∨ is_Oiface a) False (get_match r)" and
protocols_rs3: "∀r∈set ?rs3. ¬ has_disc_negated is_Prot False (get_match r)"
by(intro optimize_matches_preserves, blast)+
from ifaces have iface_in: "∀r∈set ?rs3. ¬ has_disc_negated is_Iiface False (get_match r)" and
iface_out: "∀r∈set ?rs3. ¬ has_disc_negated is_Oiface False (get_match r)"
using has_disc_negated_disj_split by blast+
from transform_upper_closure(3)[OF s3] have "∀r∈set ?rs'.
normalized_nnf_match (get_match r) ∧ normalized_src_ports (get_match r) ∧
normalized_dst_ports (get_match r) ∧ normalized_src_ips (get_match r) ∧
normalized_dst_ips (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r) ∧ ¬ has_disc is_Extra (get_match r)" .
with r have normalized:
"normalized_src_ports m ∧ normalized_dst_ports m ∧
normalized_src_ips m ∧ normalized_dst_ips m ∧
¬ has_disc is_MultiportPorts m & ¬ has_disc is_Extra m" by fastforce
from transform_upper_closure(5)[OF s3] iface_in iface_out have "∀r∈set ?rs'.
¬ has_disc_negated is_Iiface False (get_match r) ∧ ¬ has_disc_negated is_Oiface False (get_match r)" by simp
with r have abstracted_ifaces: "normalized_ifaces m"
unfolding normalized_ifaces_def has_disc_negated_disj_split by fastforce
from transform_upper_closure(3)[OF s1]
normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(1)]
normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(2)]
have "∀r∈ set ?rs2. ¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
apply(simp add: normalized_src_ports_def2 normalized_dst_ports_def2)
by blast
from this have "∀r∈set ?rs3. ¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
apply -
apply(rule optimize_matches_preserves)
apply(intro conjI)
apply(intro abstract_for_simple_firewall_preserves_nodisc_negated, simp_all)+
by (simp add: abstract_for_simple_firewall_def abstract_primitive_preserves_nodisc)
from this protocols_rs3 transform_upper_closure(5)[OF s3, where disc=is_Prot, simplified]
have "∀r∈set ?rs'. ¬ has_disc_negated is_Prot False (get_match r)"
by simp
with r have abstracted_prots: "normalized_protocols m"
unfolding normalized_protocols_def has_disc_negated_disj_split by fastforce
from no_CT no_L4_Flags s4 normalized a abstracted_ifaces abstracted_prots show "normalized_src_ports m ∧
normalized_dst_ports m ∧
normalized_src_ips m ∧
normalized_dst_ips m ∧
normalized_ifaces m ∧
normalized_protocols m ∧
¬ has_disc is_L4_Flags m ∧
¬ has_disc is_CT_State m ∧
¬ has_disc is_MultiportPorts m ∧
¬ has_disc is_Extra m ∧ (a = action.Accept ∨ a = action.Drop)"
by(simp)
}
hence simple_fw_preconditions: "check_simple_fw_preconditions ?rs'"
unfolding check_simple_fw_preconditions_def
by(clarify, rename_tac r, case_tac r, rename_tac m a, simp)
have 1: "{p. ?γ,p⊢ ⟨?rs', Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} =
{p. ?γ,p⊢ ⟨?rs3, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(subst transform_upper_closure(1)[OF s3])
by simp
from abstract_primitive_in_doubt_allow_generic(2)[OF primitive_matcher_generic_common_matcher nnf2 s2] have 2:
"{p. ?γ,p⊢ ⟨upper_closure (packet_assume_new rs), Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. ?γ,p⊢ ⟨?rs3, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
by(auto simp add: abstract_for_simple_firewall_def)
have 3: "{p. ?γ,p⊢ ⟨upper_closure (packet_assume_new rs), Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} =
{p. ?γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(subst transform_upper_closure(1)[OF s1])
apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s1]])
apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]])
using packet_assume_new newpkt_def by fastforce
have 4: "⋀p. ?γ,p⊢ ⟨?rs', Undecided⟩ ⇒⇩α Decision FinalAllow ⟷ ?fw ?rs' p = Decision FinalAllow"
using approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s4]] by fast
have "{p. ?γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. ?γ,p⊢ ⟨?rs', Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(subst 1)
apply(subst 3[symmetric])
using 2 by blast
thus "{p. ?γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. simple_fw (to_simple_firewall ?rs') p = Decision FinalAllow ∧ newpkt p}"
apply safe
subgoal for p using to_simple_firewall[OF simple_fw_preconditions, where p = p] 4 by auto
done
qed
theorem transform_simple_fw_lower:
defines "preprocess rs ≡ lower_closure (optimize_matches abstract_for_simple_firewall (lower_closure (packet_assume_new rs)))"
and "newpkt p ≡ match_tcp_flags ipt_tcp_syn (p_tcp_flags p) ∧ p_tag_ctstate p = CT_New"
assumes simplers: "simple_ruleset (rs:: 'i::len common_primitive rule list)"
shows "check_simple_fw_preconditions (preprocess rs)"
and "{p. simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow ∧ newpkt p} ⊆
{p. (common_matcher, in_doubt_deny),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
unfolding check_simple_fw_preconditions_def preprocess_def
apply(clarify, rename_tac r, case_tac r, rename_tac m a, simp)
proof -
let ?rs2="lower_closure (packet_assume_new rs)"
let ?rs3="optimize_matches abstract_for_simple_firewall ?rs2"
let ?rs'="lower_closure ?rs3"
let ?γ="(common_matcher, in_doubt_deny)
:: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
let ?fw="λrs p. approximating_bigstep_fun ?γ p rs Undecided"
from packet_assume_new_simple_ruleset[OF simplers] have s1: "simple_ruleset (packet_assume_new rs)" .
from transform_lower_closure(2)[OF s1] have s2: "simple_ruleset (lower_closure (packet_assume_new rs))" .
from s2 have s3: "simple_ruleset ?rs3" by (simp add: optimize_matches_simple_ruleset)
from transform_lower_closure(2)[OF s3] have s4: "simple_ruleset ?rs'" .
from transform_lower_closure(3)[OF s1] have nnf2:
"∀r∈set (lower_closure (packet_assume_new rs)). normalized_nnf_match (get_match r)" by simp
{ fix m a
assume r: "Rule m a ∈ set ?rs'"
from s4 r have a: "(a = action.Accept ∨ a = action.Drop)" by(auto simp add: simple_ruleset_def)
have "r ∈ set (packet_assume_new rs) ⟹ ¬ has_disc is_CT_State (get_match r)" for r
by(simp add: packet_assume_new_def ctstate_assume_new_not_has_CT_State)
with transform_lower_closure(4)[OF s1, where disc=is_CT_State] have
"∀r∈set (lower_closure (packet_assume_new rs)). ¬ has_disc is_CT_State (get_match r)"
by fastforce
with abstract_primitive_preserves_nodisc[where disc'="is_CT_State"] have
"∀r∈set ?rs3. ¬ has_disc is_CT_State (get_match r)"
apply(intro optimize_matches_preserves)
by(auto simp add: abstract_for_simple_firewall_def)
with transform_lower_closure(4)[OF s3, where disc=is_CT_State] have
"∀r∈set ?rs'. ¬ has_disc is_CT_State (get_match r)" by fastforce
with r have no_CT: "¬ has_disc is_CT_State m" by fastforce
from abstract_for_simple_firewall_hasdisc have "∀r∈set ?rs3. ¬ has_disc is_L4_Flags (get_match r)"
by(intro optimize_matches_preserves, blast)
with transform_lower_closure(4)[OF s3, where disc=is_L4_Flags] have
"∀r∈set ?rs'. ¬ has_disc is_L4_Flags (get_match r)" by fastforce
with r have no_L4_Flags: "¬ has_disc is_L4_Flags m" by fastforce
from nnf2 abstract_for_simple_firewall_negated_ifaces_prots have
ifaces: "∀r∈set ?rs3. ¬ has_disc_negated (λa. is_Iiface a ∨ is_Oiface a) False (get_match r)" and
protocols_rs3: "∀r∈set ?rs3. ¬ has_disc_negated is_Prot False (get_match r)"
by(intro optimize_matches_preserves, blast)+
from ifaces have iface_in: "∀r∈set ?rs3. ¬ has_disc_negated is_Iiface False (get_match r)" and
iface_out: "∀r∈set ?rs3. ¬ has_disc_negated is_Oiface False (get_match r)"
using has_disc_negated_disj_split by blast+
from transform_lower_closure(3)[OF s3] have "∀r∈set ?rs'.
normalized_nnf_match (get_match r) ∧ normalized_src_ports (get_match r) ∧
normalized_dst_ports (get_match r) ∧ normalized_src_ips (get_match r) ∧
normalized_dst_ips (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r) ∧ ¬ has_disc is_Extra (get_match r)" .
with r have normalized: "normalized_src_ports m ∧ normalized_dst_ports m ∧ normalized_src_ips m ∧
normalized_dst_ips m ∧ ¬ has_disc is_MultiportPorts m ∧ ¬ has_disc is_Extra m" by fastforce
from transform_lower_closure(5)[OF s3] iface_in iface_out have "∀r∈set ?rs'.
¬ has_disc_negated is_Iiface False (get_match r) ∧ ¬ has_disc_negated is_Oiface False (get_match r)" by simp
with r have abstracted_ifaces: "normalized_ifaces m"
unfolding normalized_ifaces_def has_disc_negated_disj_split by fastforce
from transform_lower_closure(3)[OF s1]
normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(1)]
normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(2)]
have "∀r∈set ?rs2. ¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
apply(simp add: normalized_src_ports_def2 normalized_dst_ports_def2)
by blast
from this have "∀r∈set ?rs3. ¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
apply -
apply(rule optimize_matches_preserves)
apply(intro conjI)
apply(intro abstract_for_simple_firewall_preserves_nodisc_negated, simp_all)+
by (simp add: abstract_for_simple_firewall_def abstract_primitive_preserves_nodisc)
from this protocols_rs3 transform_lower_closure(5)[OF s3, where disc=is_Prot, simplified]
have "∀r∈set ?rs'. ¬ has_disc_negated is_Prot False (get_match r)"
by simp
with r have abstracted_prots: "normalized_protocols m"
unfolding normalized_protocols_def has_disc_negated_disj_split by fastforce
from no_CT no_L4_Flags s4 normalized a abstracted_ifaces abstracted_prots show "normalized_src_ports m ∧
normalized_dst_ports m ∧
normalized_src_ips m ∧
normalized_dst_ips m ∧
normalized_ifaces m ∧
normalized_protocols m ∧ ¬ has_disc is_L4_Flags m ∧ ¬ has_disc is_CT_State m ∧
¬ has_disc is_MultiportPorts m ∧ ¬ has_disc is_Extra m ∧ (a = action.Accept ∨ a = action.Drop)"
by(simp)
}
hence simple_fw_preconditions: "check_simple_fw_preconditions ?rs'"
unfolding check_simple_fw_preconditions_def
by(clarify, rename_tac r, case_tac r, rename_tac m a, simp)
have 1: "{p. ?γ,p⊢ ⟨?rs', Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} =
{p. ?γ,p⊢ ⟨?rs3, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(subst transform_lower_closure(1)[OF s3])
by simp
from abstract_primitive_in_doubt_deny_generic(1)[OF primitive_matcher_generic_common_matcher nnf2 s2] have 2:
"{p. ?γ,p⊢ ⟨?rs3, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. ?γ,p⊢ ⟨lower_closure (packet_assume_new rs), Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
by(auto simp add: abstract_for_simple_firewall_def)
have 3: "{p. ?γ,p⊢ ⟨lower_closure (packet_assume_new rs), Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} =
{p. ?γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(subst transform_lower_closure(1)[OF s1])
apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s1]])
apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]])
using packet_assume_new newpkt_def by fastforce
have 4: "⋀p. ?γ,p⊢ ⟨?rs', Undecided⟩ ⇒⇩α Decision FinalAllow ⟷ ?fw ?rs' p = Decision FinalAllow"
using approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s4]] by fast
have "{p. ?γ,p⊢ ⟨?rs', Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. ?γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(subst 1)
apply(subst 3[symmetric])
using 2 by blast
thus "{p. simple_fw (to_simple_firewall ?rs') p = Decision FinalAllow ∧ newpkt p} ⊆
{p. ?γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} "
apply safe
subgoal for p using to_simple_firewall[OF simple_fw_preconditions, where p = p] 4 by auto
done
qed
definition "to_simple_firewall_without_interfaces ipassmt rtblo rs ≡
to_simple_firewall
(upper_closure
(optimize_matches (abstract_primitive (λr. case r of Pos a ⇒ is_Iiface a ∨ is_Oiface a | Neg a ⇒ is_Iiface a ∨ is_Oiface a))
(optimize_matches abstract_for_simple_firewall
(upper_closure
(iface_try_rewrite ipassmt rtblo
(upper_closure
(packet_assume_new rs)))))))"
theorem to_simple_firewall_without_interfaces:
defines "newpkt p ≡ match_tcp_flags ipt_tcp_syn (p_tcp_flags p) ∧ p_tag_ctstate p = CT_New"
assumes simplers: "simple_ruleset (rs:: 'i::len common_primitive rule list)"
and wf_ipassmt1: "ipassmt_sanity_nowildcards (map_of ipassmt)" and wf_ipassmt2: "distinct (map fst ipassmt)"
and nospoofing: "∀(p::('i::len, 'a) tagged_packet_scheme).
∃ips. (map_of ipassmt) (Iface (p_iiface p)) = Some ips ∧ p_src p ∈ ipcidr_union_set (set ips)"
and routing_decided: "⋀rtbl (p::('i,'a) tagged_packet_scheme). rtblo = Some rtbl ⟹ output_iface (routing_table_semantics rtbl (p_dst p)) = p_oiface p"
and correct_routing: "⋀rtbl. rtblo = Some rtbl ⟹ correct_routing rtbl"
and routing_no_wildcards: "⋀rtbl. rtblo = Some rtbl ⟹ ipassmt_sanity_nowildcards (map_of (routing_ipassmt rtbl))"
shows "{p::('i,'a) tagged_packet_scheme. (common_matcher, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p::('i,'a) tagged_packet_scheme. simple_fw (to_simple_firewall_without_interfaces ipassmt rtblo rs) p = Decision FinalAllow ∧ newpkt p}"
and "∀r ∈ set (to_simple_firewall_without_interfaces ipassmt rtblo rs).
iiface (match_sel r) = ifaceAny ∧ oiface (match_sel r) = ifaceAny"
proof -
let ?rs1="packet_assume_new rs"
let ?rs2="upper_closure ?rs1"
let ?rs3="iface_try_rewrite ipassmt rtblo ?rs2"
let ?rs4="upper_closure ?rs3"
let ?rs5="optimize_matches abstract_for_simple_firewall ?rs4"
let ?rs6="optimize_matches (abstract_primitive (λr. case r of Pos a ⇒ is_Iiface a ∨ is_Oiface a | Neg a ⇒ is_Iiface a ∨ is_Oiface a)) ?rs5"
let ?rs7="upper_closure ?rs6"
let ?γ="(common_matcher, in_doubt_allow)
:: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
have "to_simple_firewall_without_interfaces ipassmt rtblo rs = to_simple_firewall ?rs7"
by(simp add: to_simple_firewall_without_interfaces_def)
from packet_assume_new_simple_ruleset[OF simplers] have s1: "simple_ruleset ?rs1" .
from transform_upper_closure(2)[OF s1] have s2: "simple_ruleset ?rs2" .
from iface_try_rewrite_simplers[OF s2] have s3: "simple_ruleset ?rs3" .
from transform_upper_closure(2)[OF s3] have s4: "simple_ruleset ?rs4" .
from optimize_matches_simple_ruleset[OF s4] have s5: "simple_ruleset ?rs5" .
from optimize_matches_simple_ruleset[OF s5] have s6: "simple_ruleset ?rs6" .
from transform_upper_closure(2)[OF s6] have s7: "simple_ruleset ?rs7" .
from transform_upper_closure(3)[OF s1] have nnf2: "∀r∈set ?rs2. normalized_nnf_match (get_match r)" by simp
from transform_upper_closure(3)[OF s3] have nnf4: "∀r∈set ?rs4. normalized_nnf_match (get_match r)" by simp
have nnf5: "∀r∈set ?rs5. normalized_nnf_match (get_match r)"
apply(intro optimize_matches_preserves)
apply(simp add: abstract_for_simple_firewall_def)
apply(rule abstract_primitive_preserves_normalized(5))
using nnf4 by(simp)
have nnf6: "∀r∈set ?rs6. normalized_nnf_match (get_match r)"
apply(intro optimize_matches_preserves)
apply(rule abstract_primitive_preserves_normalized(5))
using nnf5 by(simp)
from transform_upper_closure(3)[OF s6] have nnf7: "∀r∈set ?rs7. normalized_nnf_match (get_match r)" by simp
{ fix m a
assume r: "Rule m a ∈ set ?rs7"
from s7 r have a: "(a = action.Accept ∨ a = action.Drop)" by(auto simp add: simple_ruleset_def)
from abstract_for_simple_firewall_hasdisc have "∀r∈set ?rs5. ¬ has_disc is_CT_State (get_match r)"
by(intro optimize_matches_preserves, blast)
with abstract_primitive_preserves_nodisc[where disc'="is_CT_State"] have
"∀r∈set ?rs6. ¬ has_disc is_CT_State (get_match r)"
apply(intro optimize_matches_preserves)
apply(simp)
by blast
with transform_upper_closure(4)[OF s6, where disc=is_CT_State] have
"∀r∈set ?rs7. ¬ has_disc is_CT_State (get_match r)" by simp
with r have no_CT: "¬ has_disc is_CT_State m" by fastforce
from abstract_for_simple_firewall_hasdisc have "∀r∈set ?rs5. ¬ has_disc is_L4_Flags (get_match r)"
by(intro optimize_matches_preserves, blast)
with abstract_primitive_preserves_nodisc[where disc'="is_L4_Flags"] have
"∀r∈set ?rs6. ¬ has_disc is_L4_Flags (get_match r)"
by(intro optimize_matches_preserves) auto
with transform_upper_closure(4)[OF s6, where disc=is_L4_Flags] have
"∀r∈set ?rs7. ¬ has_disc is_L4_Flags (get_match r)" by simp
with r have no_L4_Flags: "¬ has_disc is_L4_Flags m" by fastforce
have "∀r∈set ?rs6. ¬ has_disc is_Iiface (get_match r)"
by(intro optimize_matches_preserves abstract_primitive_nodisc) simp+
with transform_upper_closure(4)[OF s6, where disc=is_Iiface] have
"∀r∈set ?rs7. ¬ has_disc is_Iiface (get_match r)" by simp
with r have no_Iiface: "¬ has_disc is_Iiface m" by fastforce
have "∀r∈set ?rs6. ¬ has_disc is_Oiface (get_match r)"
by(intro optimize_matches_preserves abstract_primitive_nodisc) simp+
with transform_upper_closure(4)[OF s6, where disc=is_Oiface] have
"∀r∈set ?rs7. ¬ has_disc is_Oiface (get_match r)" by simp
with r have no_Oiface: "¬ has_disc is_Oiface m" by fastforce
from no_Iiface no_Oiface have normalized_ifaces: "normalized_ifaces m"
using has_disc_negated_disj_split has_disc_negated_has_disc normalized_ifaces_def by blast
from transform_upper_closure(3)[OF s6] r have normalized:
"normalized_src_ports m ∧ normalized_dst_ports m ∧
normalized_src_ips m ∧ normalized_dst_ips m ∧
¬ has_disc is_MultiportPorts m ∧ ¬ has_disc is_Extra m" by fastforce
from transform_upper_closure(3)[OF s3, simplified]
normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(1)]
normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(2)]
have "∀r ∈ set ?rs4. ¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
apply(simp add: normalized_src_ports_def2 normalized_dst_ports_def2)
by blast
hence "∀r ∈ set ?rs5. ¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
apply -
apply(rule optimize_matches_preserves)
apply(intro conjI)
apply(intro abstract_for_simple_firewall_preserves_nodisc_negated, simp_all)+
by (simp add: abstract_for_simple_firewall_def abstract_primitive_preserves_nodisc)
from this have no_ports_rs6:
"∀r ∈ set ?rs6. ¬ has_disc_negated is_Src_Ports False (get_match r) ∧
¬ has_disc_negated is_Dst_Ports False (get_match r) ∧
¬ has_disc is_MultiportPorts (get_match r)"
apply -
apply(rule optimize_matches_preserves)
apply(intro conjI)
apply(intro abstract_primitive_preserves_nodisc_nedgated, simp_all)+
by (simp add: abstract_for_simple_firewall_def abstract_primitive_preserves_nodisc)
from nnf4 abstract_for_simple_firewall_negated_ifaces_prots(2) have
"∀r∈set ?rs5. ¬ has_disc_negated is_Prot False (get_match r)"
by(intro optimize_matches_preserves) blast
hence "∀r∈set ?rs6. ¬ has_disc_negated is_Prot False (get_match r)"
by(intro optimize_matches_preserves abstract_primitive_preserves_nodisc_nedgated) simp+
with no_ports_rs6 have "∀r∈set ?rs7. ¬ has_disc_negated is_Prot False (get_match r)"
by(intro transform_upper_closure(5)[OF s6]) simp+
with r have protocols: "normalized_protocols m" unfolding normalized_protocols_def by fastforce
from no_CT no_L4_Flags normalized a normalized_ifaces protocols no_Iiface no_Oiface
have "normalized_src_ports m ∧
normalized_dst_ports m ∧
normalized_src_ips m ∧
normalized_dst_ips m ∧
normalized_ifaces m ∧
normalized_protocols m ∧
¬ has_disc is_L4_Flags m ∧
¬ has_disc is_CT_State m ∧
¬ has_disc is_MultiportPorts m ∧
¬ has_disc is_Extra m ∧ (a = action.Accept ∨ a = action.Drop)"
and "¬ has_disc is_Iiface m" and "¬ has_disc is_Oiface m"
apply -
by(simp)+
}
hence simple_fw_preconditions: "check_simple_fw_preconditions ?rs7"
and no_interfaces: "Rule m a ∈ set ?rs7 ⟹ ¬ has_disc is_Iiface m ∧ ¬ has_disc is_Oiface m" for m a
apply -
subgoal unfolding check_simple_fw_preconditions_def by(clarify, rename_tac r, case_tac r, rename_tac m a, simp)
by simp
have "{p :: ('i,'a) tagged_packet_scheme. ?γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} =
{p :: ('i,'a) tagged_packet_scheme. ?γ,p⊢ ⟨?rs1, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s1]])
apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]])
apply(rule Collect_cong)
subgoal for p using packet_assume_new[where p = p] newpkt_def[where p = p] by auto
done
also have "{p. ?γ,p⊢ ⟨?rs1, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} =
{p. ?γ,p⊢ ⟨?rs2, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(subst transform_upper_closure(1)[OF s1])
by simp
also have "… = {p. ?γ,p⊢ ⟨?rs3, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(cases rtblo; simp; (subst iface_try_rewrite_rtbl[OF s2 nnf2] | subst iface_try_rewrite_no_rtbl[OF s2 nnf2]))
using wf_ipassmt1 wf_ipassmt2 nospoofing wf_in_doubt_allow routing_no_wildcards correct_routing routing_decided by simp_all
also have "… = {p. ?γ,p⊢ ⟨?rs4, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(subst transform_upper_closure(1)[OF s3])
by simp
finally have 1: "{p. ?γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} =
{p. ?γ,p⊢ ⟨?rs4, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}" .
from abstract_primitive_in_doubt_allow_generic(2)[OF primitive_matcher_generic_common_matcher nnf4 s4] have 2:
"{p. ?γ,p⊢ ⟨?rs4, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. ?γ,p⊢ ⟨?rs5, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
by(auto simp add: abstract_for_simple_firewall_def)
from abstract_primitive_in_doubt_allow_generic(2)[OF primitive_matcher_generic_common_matcher nnf5 s5] have 3:
"{p. ?γ,p⊢ ⟨?rs5, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. ?γ,p⊢ ⟨?rs6, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
by(auto simp add: abstract_for_simple_firewall_def)
have 4: "{p. ?γ,p⊢ ⟨?rs6, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} =
{p. ?γ,p⊢ ⟨?rs7, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(subst transform_upper_closure(1)[OF s6])
by simp
let ?fw="λrs p. approximating_bigstep_fun ?γ p rs Undecided"
have approximating_rule: "⋀p. ?γ,p⊢ ⟨?rs7, Undecided⟩ ⇒⇩α Decision FinalAllow ⟷ ?fw ?rs7 p = Decision FinalAllow"
using approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s7]] by fast
from 1 2 3 4 have "{p. ?γ,p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. ?γ,p⊢ ⟨?rs7, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}" by blast
thus "{p. (common_matcher, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. simple_fw (to_simple_firewall_without_interfaces ipassmt rtblo rs) p = Decision FinalAllow ∧ newpkt p}"
apply(safe)
subgoal for p
unfolding to_simple_firewall_without_interfaces_def
using to_simple_firewall[OF simple_fw_preconditions, where p = p] approximating_rule[where p = p] by auto
done
have common_primitive_match_to_simple_match_nodisc:
"Some sm = common_primitive_match_to_simple_match m' ⟹
¬ has_disc is_Iiface m' ∧ ¬ has_disc is_Oiface m' ⟹ iiface sm = ifaceAny ∧ oiface sm = ifaceAny"
if prems: "check_simple_fw_preconditions [Rule m' a']"
for m' :: "'i common_primitive match_expr" and a' sm
using prems proof(induction m' arbitrary: sm rule: common_primitive_match_to_simple_match.induct)
case 18 thus ?case
by(simp add: check_simple_fw_preconditions_def normalized_protocols_def)
next
case (13 m1 m2) thus ?case
apply(simp add: check_simple_fw_preconditions_def)
apply(case_tac "common_primitive_match_to_simple_match m1")
apply(simp; fail)
apply(case_tac "common_primitive_match_to_simple_match m2")
apply(simp; fail)
apply simp
apply(rename_tac a aa)
apply(case_tac a)
apply(case_tac aa)
apply(simp)
apply(simp split: option.split_asm)
using iface_conjunct_ifaceAny normalized_ifaces_def normalized_protocols_def
by (metis has_disc_negated.simps(4) option.inject)
qed(simp_all add: check_simple_fw_preconditions_def simple_match_any_def)
have to_simple_firewall_no_ifaces: "(⋀m a. Rule m a ∈ set rs ⟹ ¬ has_disc is_Iiface m ∧ ¬ has_disc is_Oiface m) ⟹
∀r∈set (to_simple_firewall rs). iiface (match_sel r) = ifaceAny ∧ oiface (match_sel r) = ifaceAny"
if pre1: "check_simple_fw_preconditions rs" for rs :: "'i common_primitive rule list"
using pre1 apply(induction rs)
apply(simp add: to_simple_firewall_simps; fail)
apply simp
apply(subgoal_tac "check_simple_fw_preconditions rs")
prefer 2
subgoal by(simp add: check_simple_fw_preconditions_def)
apply(rename_tac r rs, case_tac r)
apply simp
apply(simp add: to_simple_firewall_simps)
apply(simp split: option.split)
apply(intro conjI)
apply blast
apply(intro allI impI)
apply(subgoal_tac "(∀m∈set (to_simple_firewall rs). iiface (match_sel m) = ifaceAny ∧ oiface (match_sel m) = ifaceAny)")
prefer 2
subgoal by blast
apply(simp)
apply(rename_tac m' a' sm)
apply(subgoal_tac " ¬ has_disc is_Iiface m' ∧ ¬ has_disc is_Oiface m'")
prefer 2
subgoal by blast
apply(subgoal_tac "check_simple_fw_preconditions [Rule m' a']")
prefer 2
subgoal by(simp add: check_simple_fw_preconditions_def)
apply(drule common_primitive_match_to_simple_match_nodisc)
apply(simp_all)
done
from to_simple_firewall_no_ifaces[OF simple_fw_preconditions no_interfaces] show
"∀r ∈ set (to_simple_firewall_without_interfaces ipassmt rtblo rs). iiface (match_sel r) = ifaceAny ∧ oiface (match_sel r) = ifaceAny"
unfolding to_simple_firewall_without_interfaces_def
by(simp add: to_simple_firewall_def simple_fw_preconditions)
qed
end
Theory Semantics_Embeddings
theory Semantics_Embeddings
imports "Simple_Firewall/SimpleFw_Compliance" Matching_Embeddings Semantics "Semantics_Ternary/Semantics_Ternary"
begin
section‹Semantics Embedding›
subsection‹Tactic @{const in_doubt_allow}›
lemma iptables_bigstep_undecided_to_undecided_in_doubt_allow_approx:
assumes agree: "matcher_agree_on_exact_matches γ β"
and good: "good_ruleset rs" and semantics: "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided"
shows "(β, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Undecided ∨ (β, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow"
proof -
from semantics good show ?thesis
proof(induction rs Undecided Undecided rule: iptables_bigstep_induct)
case Skip thus ?case by(auto intro: approximating_bigstep.skip)
next
case Log thus ?case by(auto intro: approximating_bigstep.empty approximating_bigstep.log approximating_bigstep.nomatch)
next
case (Nomatch m a)
with not_exact_match_in_doubt_allow_approx_match[OF agree] have
"a ≠ Log ⟹ a ≠ Empty ⟹ a = Accept ∧ Matching_Ternary.matches (β, in_doubt_allow) m a p ∨ ¬ Matching_Ternary.matches (β, in_doubt_allow) m a p"
by(simp add: good_ruleset_alt) blast
thus ?case
by(cases a) (auto intro: approximating_bigstep.empty approximating_bigstep.log approximating_bigstep.accept approximating_bigstep.nomatch)
next
case (Seq rs rs1 rs2 t)
from Seq have "good_ruleset rs1" and "good_ruleset rs2" by(simp_all add: good_ruleset_append)
also from Seq iptables_bigstep_to_undecided have "t = Undecided" by simp
ultimately show ?case using Seq by(fastforce intro: approximating_bigstep.decision Semantics_Ternary.seq')
qed(simp_all add: good_ruleset_def)
qed
lemma FinalAllow_approximating_in_doubt_allow:
assumes agree: "matcher_agree_on_exact_matches γ β"
and good: "good_ruleset rs" and semantics: "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow"
shows "(β, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow"
proof -
from semantics good show ?thesis
proof(induction rs Undecided "Decision FinalAllow" rule: iptables_bigstep_induct)
case Allow thus ?case
by (auto intro: agree approximating_bigstep.accept in_doubt_allow_allows_Accept)
next
case (Seq rs rs1 rs2 t)
from Seq have good1: "good_ruleset rs1" and good2: "good_ruleset rs2" by(simp_all add: good_ruleset_append)
show ?case
proof(cases t)
case Decision with Seq good1 good2 show "(β, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow"
by (auto intro: approximating_bigstep.decision approximating_bigstep.seq dest: Semantics.decisionD)
next
case Undecided
with iptables_bigstep_undecided_to_undecided_in_doubt_allow_approx[OF agree good1] Seq have
"(β, in_doubt_allow),p⊢ ⟨rs1, Undecided⟩ ⇒⇩α Undecided ∨ (β, in_doubt_allow),p⊢ ⟨rs1, Undecided⟩ ⇒⇩α Decision FinalAllow" by simp
with Undecided Seq good1 good2 show "(β, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow"
by (auto intro: approximating_bigstep.seq Semantics_Ternary.seq' approximating_bigstep.decision)
qed
next
case Call_result thus ?case by(simp add: good_ruleset_alt)
qed
qed
corollary FinalAllows_subseteq_in_doubt_allow: "matcher_agree_on_exact_matches γ β ⟹ good_ruleset rs ⟹
{p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow} ⊆ {p. (β, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow}"
using FinalAllow_approximating_in_doubt_allow by (metis (lifting, full_types) Collect_mono)
corollary new_packets_to_simple_firewall_overapproximation:
defines "preprocess rs ≡ upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new rs)))"
and "newpkt p ≡ match_tcp_flags ipt_tcp_syn (p_tcp_flags p) ∧ p_tag_ctstate p = CT_New"
fixes p :: "('i::len, 'pkt_ext) tagged_packet_scheme"
assumes "matcher_agree_on_exact_matches γ common_matcher" and "simple_ruleset rs"
shows "{p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow ∧ newpkt p} ⊆ {p. simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow ∧ newpkt p}"
proof -
from assms(3) have "{p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow ∧ newpkt p} ⊆
{p. (common_matcher, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(drule_tac rs=rs and Γ=Γ in FinalAllows_subseteq_in_doubt_allow)
using simple_imp_good_ruleset assms(4) apply blast
by blast
thus ?thesis unfolding newpkt_def preprocess_def using transform_simple_fw_upper(2)[OF assms(4)] by blast
qed
lemma approximating_bigstep_undecided_to_undecided_in_doubt_allow_approx: "matcher_agree_on_exact_matches γ β ⟹
good_ruleset rs ⟹
(β, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Undecided ⟹ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided ∨ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalDeny"
apply(rotate_tac 2)
apply(induction rs Undecided Undecided rule: approximating_bigstep_induct)
apply(simp_all)
apply (metis iptables_bigstep.skip)
apply (metis iptables_bigstep.empty iptables_bigstep.log iptables_bigstep.nomatch)
apply(simp split: ternaryvalue.split_asm add: matches_case_ternaryvalue_tuple)
apply (metis in_doubt_allow_allows_Accept iptables_bigstep.nomatch matches_casesE ternaryvalue.distinct(1) ternaryvalue.distinct(5))
apply(case_tac a)
apply(simp_all)
apply (metis iptables_bigstep.drop iptables_bigstep.nomatch)
apply (metis iptables_bigstep.log iptables_bigstep.nomatch)
apply (metis iptables_bigstep.nomatch iptables_bigstep.reject)
apply(simp add: good_ruleset_alt)
apply(simp add: good_ruleset_alt)
apply(simp add: good_ruleset_alt)
apply (metis iptables_bigstep.empty iptables_bigstep.nomatch)
apply(simp add: good_ruleset_alt)
apply(simp add: good_ruleset_append,clarify)
by (metis approximating_bigstep_to_undecided iptables_bigstep.decision iptables_bigstep.seq)
lemma FinalDeny_approximating_in_doubt_allow: "matcher_agree_on_exact_matches γ β ⟹
good_ruleset rs ⟹
(β, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalDeny ⟹ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalDeny"
apply(rotate_tac 2)
apply(induction rs Undecided "Decision FinalDeny" rule: approximating_bigstep_induct)
apply(simp_all)
apply (metis action.distinct(1) action.distinct(5) deny not_exact_match_in_doubt_allow_approx_match)
apply(simp add: good_ruleset_append, clarify)
apply(case_tac t)
apply(simp)
apply(drule(2) approximating_bigstep_undecided_to_undecided_in_doubt_allow_approx[where Γ=Γ])
apply(erule disjE)
apply (metis iptables_bigstep.seq)
apply (metis iptables_bigstep.decision iptables_bigstep.seq)
by (metis Decision_approximating_bigstep_fun approximating_semantics_imp_fun iptables_bigstep.decision iptables_bigstep.seq)
corollary FinalDenys_subseteq_in_doubt_allow: "matcher_agree_on_exact_matches γ β ⟹ good_ruleset rs ⟹
{p. (β, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalDeny} ⊆ {p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalDeny}"
using FinalDeny_approximating_in_doubt_allow by (metis (lifting, full_types) Collect_mono)
text‹
If our approximating firewall (the executable version) concludes that we deny a packet,
the exact semantic agrees that this packet is definitely denied!
›
corollary "matcher_agree_on_exact_matches γ β ⟹ good_ruleset rs ⟹
approximating_bigstep_fun (β, in_doubt_allow) p rs Undecided = (Decision FinalDeny) ⟹ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalDeny"
apply(frule(1) FinalDeny_approximating_in_doubt_allow[where p=p and Γ=Γ])
apply(rule approximating_fun_imp_semantics)
apply (metis good_imp_wf_ruleset)
apply(simp_all)
done
subsection‹Tactic @{const in_doubt_deny}›
lemma iptables_bigstep_undecided_to_undecided_in_doubt_deny_approx: "matcher_agree_on_exact_matches γ β ⟹
good_ruleset rs ⟹
Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided ⟹
(β, in_doubt_deny),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Undecided ∨ (β, in_doubt_deny),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalDeny"
apply(rotate_tac 2)
apply(induction rs Undecided Undecided rule: iptables_bigstep_induct)
apply(simp_all)
apply (metis approximating_bigstep.skip)
apply (metis approximating_bigstep.empty approximating_bigstep.log approximating_bigstep.nomatch)
apply(case_tac "a = Log")
apply (metis approximating_bigstep.log approximating_bigstep.nomatch)
apply(case_tac "a = Empty")
apply (metis approximating_bigstep.empty approximating_bigstep.nomatch)
apply(drule_tac a=a in not_exact_match_in_doubt_deny_approx_match)
apply(simp_all)
apply(simp add: good_ruleset_alt)
apply fast
apply (metis approximating_bigstep.drop approximating_bigstep.nomatch approximating_bigstep.reject)
apply(frule iptables_bigstep_to_undecided)
apply(simp)
apply(simp add: good_ruleset_append)
apply (metis (hide_lams, no_types) approximating_bigstep.decision Semantics_Ternary.seq')
apply(simp add: good_ruleset_def)
apply(simp add: good_ruleset_def)
done
lemma FinalDeny_approximating_in_doubt_deny: "matcher_agree_on_exact_matches γ β ⟹
good_ruleset rs ⟹
Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalDeny ⟹ (β, in_doubt_deny),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalDeny"
apply(rotate_tac 2)
apply(induction rs Undecided "Decision FinalDeny" rule: iptables_bigstep_induct)
apply(simp_all)
apply (metis approximating_bigstep.drop approximating_bigstep.reject in_doubt_deny_denies_DropReject)
apply(case_tac t)
apply(simp_all)
prefer 2
apply(simp add: good_ruleset_append)
apply (metis approximating_bigstep.decision approximating_bigstep.seq Semantics.decisionD state.inject)
apply(simp add: good_ruleset_append, clarify)
apply(drule(2) iptables_bigstep_undecided_to_undecided_in_doubt_deny_approx)
apply(erule disjE)
apply (metis approximating_bigstep.seq)
apply (metis approximating_bigstep.decision Semantics_Ternary.seq')
apply(simp add: good_ruleset_alt)
done
lemma approximating_bigstep_undecided_to_undecided_in_doubt_deny_approx: "matcher_agree_on_exact_matches γ β ⟹
good_ruleset rs ⟹
(β, in_doubt_deny),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Undecided ⟹ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Undecided ∨ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow"
apply(rotate_tac 2)
apply(induction rs Undecided Undecided rule: approximating_bigstep_induct)
apply(simp_all)
apply (metis iptables_bigstep.skip)
apply (metis iptables_bigstep.empty iptables_bigstep.log iptables_bigstep.nomatch)
apply(simp split: ternaryvalue.split_asm add: matches_case_ternaryvalue_tuple)
apply (metis in_doubt_allow_allows_Accept iptables_bigstep.nomatch matches_casesE ternaryvalue.distinct(1) ternaryvalue.distinct(5))
apply(case_tac a)
apply(simp_all)
apply (metis iptables_bigstep.accept iptables_bigstep.nomatch)
apply (metis iptables_bigstep.log iptables_bigstep.nomatch)
apply(simp add: good_ruleset_alt)
apply(simp add: good_ruleset_alt)
apply(simp add: good_ruleset_alt)
apply (metis iptables_bigstep.empty iptables_bigstep.nomatch)
apply(simp add: good_ruleset_alt)
apply(simp add: good_ruleset_append,clarify)
by (metis approximating_bigstep_to_undecided iptables_bigstep.decision iptables_bigstep.seq)
lemma FinalAllow_approximating_in_doubt_deny: "matcher_agree_on_exact_matches γ β ⟹
good_ruleset rs ⟹
(β, in_doubt_deny),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ⟹ Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow"
apply(rotate_tac 2)
apply(induction rs Undecided "Decision FinalAllow" rule: approximating_bigstep_induct)
apply(simp_all)
apply (metis action.distinct(1) action.distinct(5) iptables_bigstep.accept not_exact_match_in_doubt_deny_approx_match)
apply(simp add: good_ruleset_append, clarify)
apply(case_tac t)
apply(simp)
apply(drule(2) approximating_bigstep_undecided_to_undecided_in_doubt_deny_approx[where Γ=Γ])
apply(erule disjE)
apply (metis iptables_bigstep.seq)
apply (metis iptables_bigstep.decision iptables_bigstep.seq)
by (metis Decision_approximating_bigstep_fun approximating_semantics_imp_fun iptables_bigstep.decision iptables_bigstep.seq)
corollary FinalAllows_subseteq_in_doubt_deny: "matcher_agree_on_exact_matches γ β ⟹ good_ruleset rs ⟹
{p. (β, in_doubt_deny),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow} ⊆ {p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow}"
using FinalAllow_approximating_in_doubt_deny by (metis (lifting, full_types) Collect_mono)
corollary new_packets_to_simple_firewall_underapproximation:
defines "preprocess rs ≡ lower_closure (optimize_matches abstract_for_simple_firewall (lower_closure (packet_assume_new rs)))"
and "newpkt p ≡ match_tcp_flags ipt_tcp_syn (p_tcp_flags p) ∧ p_tag_ctstate p = CT_New"
fixes p :: "('i::len, 'pkt_ext) tagged_packet_scheme"
assumes "matcher_agree_on_exact_matches γ common_matcher" and "simple_ruleset rs"
shows "{p. simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow ∧ newpkt p} ⊆ {p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow ∧ newpkt p}"
proof -
from assms(3) have "{p. (common_matcher, in_doubt_deny),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow ∧ newpkt p}"
apply(drule_tac rs=rs and Γ=Γ in FinalAllows_subseteq_in_doubt_deny)
using simple_imp_good_ruleset assms(4) apply blast
by blast
thus ?thesis unfolding newpkt_def preprocess_def using transform_simple_fw_lower(2)[OF assms(4)] by blast
qed
subsection‹Approximating Closures›
theorem FinalAllowClosure:
assumes "matcher_agree_on_exact_matches γ β" and "good_ruleset rs"
shows "{p. (β, in_doubt_deny),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow} ⊆ {p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow}"
and "{p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow} ⊆ {p. (β, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow}"
apply (metis FinalAllows_subseteq_in_doubt_deny assms)
by (metis FinalAllows_subseteq_in_doubt_allow assms)
theorem FinalDenyClosure:
assumes "matcher_agree_on_exact_matches γ β" and "good_ruleset rs"
shows "{p. (β, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalDeny} ⊆ {p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalDeny}"
and "{p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalDeny} ⊆ {p. (β, in_doubt_deny),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalDeny}"
apply (metis FinalDenys_subseteq_in_doubt_allow assms)
by (metis FinalDeny_approximating_in_doubt_deny assms mem_Collect_eq subsetI)
subsection‹Exact Embedding›
lemma LukassLemma: assumes agree: "matcher_agree_on_exact_matches γ β"
and noUnknown: "(∀ r ∈ set rs. ternary_ternary_eval (map_match_tac β p (get_match r)) ≠ TernaryUnknown)"
and good: "good_ruleset rs"
shows "(β,α),p⊢ ⟨rs, s⟩ ⇒⇩α t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
proof -
{ fix t
assume a: "(β,α),p⊢ ⟨rs, s⟩ ⇒⇩α t"
from a good agree noUnknown have "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
proof(induction rs s t rule: approximating_bigstep_induct)
qed(auto intro: approximating_bigstep.intros iptables_bigstep.intros dest: iptables_bigstepD dest: matches_comply_exact simp: good_ruleset_append)
} note 1=this
{
assume a: "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
obtain x where "approximating_bigstep_fun (β,α) p rs s = x" by simp
with approximating_fun_imp_semantics[OF good_imp_wf_ruleset[OF good]] have x: "(β,α),p⊢ ⟨rs, s⟩ ⇒⇩α x" by fast
with 1 have "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ x" by simp
with a iptables_bigstep_deterministic have "x = t" by metis
hence "(β,α),p⊢ ⟨rs, s⟩ ⇒⇩α t" using x by blast
} note 2=this
from 1 2 show ?thesis by blast
qed
text‹
For rulesets without @{term Call}s, the approximating ternary semantics can perfectly simulate the Boolean semantics.
›
theorem β⇩m⇩a⇩g⇩i⇩c_approximating_bigstep_iff_iptables_bigstep:
assumes "∀r ∈ set rs. ∀c. get_action r ≠ Call c"
shows "((β⇩m⇩a⇩g⇩i⇩c γ),α),p⊢ ⟨rs, s⟩ ⇒⇩α t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
apply(rule iffI)
apply(induction rs s t rule: approximating_bigstep_induct)
apply(auto intro: iptables_bigstep.intros simp: β⇩m⇩a⇩g⇩i⇩c_matching)[7]
apply(insert assms)
apply(induction rs s t rule: iptables_bigstep_induct)
apply(auto intro: approximating_bigstep.intros simp: β⇩m⇩a⇩g⇩i⇩c_matching)
done
corollary β⇩m⇩a⇩g⇩i⇩c_approximating_bigstep_fun_iff_iptables_bigstep:
assumes "good_ruleset rs"
shows "approximating_bigstep_fun (β⇩m⇩a⇩g⇩i⇩c γ,α) p rs s = t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
apply(subst approximating_semantics_iff_fun_good_ruleset[symmetric])
using assms apply simp
apply(subst β⇩m⇩a⇩g⇩i⇩c_approximating_bigstep_iff_iptables_bigstep[where Γ=Γ])
using assms apply (simp add: good_ruleset_def)
by simp
text‹The function @{const optimize_primitive_univ} was only applied to the ternary semantics.
It is, in fact, also correct for the Boolean semantics, assuming the @{const common_matcher}.›
lemma Semantics_optimize_primitive_univ_common_matcher:
assumes "matcher_agree_on_exact_matches γ common_matcher"
shows "Semantics.matches γ (optimize_primitive_univ m) p = Semantics.matches γ m p"
proof -
have "65535 = (max_word::16 word)"
by simp
then have port_range: "⋀s e port. s = 0 ∧ e = 0xFFFF ⟶ (port::16 word) ≤ 0xFFFF"
by (simp only:) simp
from assms show ?thesis
apply(induction m rule: optimize_primitive_univ.induct)
apply(auto elim!: matcher_agree_on_exact_matches_gammaE
simp add: port_range match_ifaceAny ipset_from_cidr_0 ctstate_is_UNIV)
done
qed
end
Theory Iptables_Semantics
theory Iptables_Semantics
imports Semantics_Embeddings "Semantics_Ternary/Normalized_Matches"
begin
section‹Normalizing Rulesets in the Boolean Big Step Semantics›
corollary normalize_rules_dnf_correct_BooleanSemantics:
assumes "good_ruleset rs"
shows "Γ,γ,p⊢ ⟨normalize_rules_dnf rs, s⟩ ⇒ t ⟷ Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"
proof -
from assms have assm': "good_ruleset (normalize_rules_dnf rs)" by (metis good_ruleset_normalize_rules_dnf)
from normalize_rules_dnf_correct assms good_imp_wf_ruleset have
"∀β α. approximating_bigstep_fun (β,α) p (normalize_rules_dnf rs) s = approximating_bigstep_fun (β,α) p rs s" by fast
hence
"∀α. approximating_bigstep_fun (β⇩m⇩a⇩g⇩i⇩c γ,α) p (normalize_rules_dnf rs) s = approximating_bigstep_fun (β⇩m⇩a⇩g⇩i⇩c γ,α) p rs s" by fast
with β⇩m⇩a⇩g⇩i⇩c_approximating_bigstep_fun_iff_iptables_bigstep assms assm' show ?thesis
by metis
qed
end
Theory Code_Interface
theory Code_Interface
imports
Common_Primitive_toString
IP_Addresses.IP_Address_Parser
"../Call_Return_Unfolding"
Transform
No_Spoof
"../Simple_Firewall/SimpleFw_Compliance"
Simple_Firewall.SimpleFw_toString
Simple_Firewall.Service_Matrix
"../Semantics_Ternary/Optimizing"
"../Semantics_Goto"
Native_Word.Code_Target_Bits_Int
"HOL-Library.Code_Target_Nat"
"HOL-Library.Code_Target_Int"
begin
section‹Code Interface›
text‹HACK: rewrite quotes such that they are better printable by Isabelle›
definition quote_rewrite :: "string ⇒ string" where
"quote_rewrite ≡ map (λc. if c = char_of_nat 34 then CHR ''~'' else c)"
lemma "quote_rewrite (''foo''@[char_of_nat 34]) = ''foo~''" by eval
text‹The parser returns the @{typ "'i::len common_primitive ruleset"} not as a map but as an association list.
This function converts it›
definition map_of_string_ipv4
:: "(string × 32 common_primitive rule list) list ⇒ string ⇀ 32 common_primitive rule list" where
"map_of_string_ipv4 rs = map_of rs"
definition map_of_string_ipv6
:: "(string × 128 common_primitive rule list) list ⇒ string ⇀ 128 common_primitive rule list" where
"map_of_string_ipv6 rs = map_of rs"
definition map_of_string
:: "(string × 'i common_primitive rule list) list ⇒ string ⇀ 'i common_primitive rule list" where
"map_of_string rs = map_of rs"
definition unfold_ruleset_CHAIN_safe :: "string ⇒ action ⇒ 'i::len common_primitive ruleset ⇒ 'i common_primitive rule list option" where
"unfold_ruleset_CHAIN_safe = unfold_optimize_ruleset_CHAIN optimize_primitive_univ"
lemma "(unfold_ruleset_CHAIN_safe chain a rs = Some rs') ⟹ simple_ruleset rs'"
by(simp add: Let_def unfold_ruleset_CHAIN_safe_def unfold_optimize_ruleset_CHAIN_def split: if_split_asm)
definition unfold_ruleset_CHAIN :: "string ⇒ action ⇒ 'i::len common_primitive ruleset ⇒ 'i common_primitive rule list" where
"unfold_ruleset_CHAIN chain default_action rs = the (unfold_ruleset_CHAIN_safe chain default_action rs)"
definition unfold_ruleset_FORWARD :: "action ⇒ 'i::len common_primitive ruleset ⇒ 'i::len common_primitive rule list" where
"unfold_ruleset_FORWARD = unfold_ruleset_CHAIN ''FORWARD''"
definition unfold_ruleset_INPUT :: "action ⇒ 'i::len common_primitive ruleset ⇒ 'i::len common_primitive rule list" where
"unfold_ruleset_INPUT = unfold_ruleset_CHAIN ''INPUT''"
definition unfold_ruleset_OUTPUT :: "action ⇒ 'i::len common_primitive ruleset ⇒ 'i::len common_primitive rule list" where
"unfold_ruleset_OUTPUT ≡ unfold_ruleset_CHAIN ''OUTPUT''"
lemma "let fw = [''FORWARD'' ↦ []] in
unfold_ruleset_FORWARD action.Drop fw
= [Rule (MatchAny :: 32 common_primitive match_expr) action.Drop]" by eval
definition nat_to_8word :: "nat ⇒ 8 word" where
"nat_to_8word i ≡ of_nat i"
definition nat_to_16word :: "nat ⇒ 16 word" where
"nat_to_16word i ≡ of_nat i"
definition integer_to_16word :: "integer ⇒ 16 word" where
"integer_to_16word i ≡ nat_to_16word (nat_of_integer i)"
context
begin
private definition is_pos_Extra :: "'i::len common_primitive negation_type ⇒ bool" where
"is_pos_Extra a ≡ (case a of Pos (Extra _) ⇒ True | _ ⇒ False)"
private definition get_pos_Extra :: "'i::len common_primitive negation_type ⇒ string" where
"get_pos_Extra a ≡ (case a of Pos (Extra e) ⇒ e | _ ⇒ undefined)"
fun compress_parsed_extra
:: "'i::len common_primitive negation_type list ⇒ 'i common_primitive negation_type list" where
"compress_parsed_extra [] = []" |
"compress_parsed_extra (a1#a2#as) = (if is_pos_Extra a1 ∧ is_pos_Extra a2
then compress_parsed_extra (Pos (Extra (get_pos_Extra a1@'' ''@get_pos_Extra a2))#as)
else a1#compress_parsed_extra (a2#as)
)" |
"compress_parsed_extra (a#as) = a#compress_parsed_extra as"
lemma "compress_parsed_extra
(map Pos [Extra ''-m'', (Extra ''recent'' :: 32 common_primitive),
Extra ''--update'', Extra ''--seconds'', Extra ''60'',
IIface (Iface ''foobar''),
Extra ''--name'', Extra ''DEFAULT'', Extra ''--rsource'']) =
map Pos [Extra ''-m recent --update --seconds 60'',
IIface (Iface ''foobar''),
Extra ''--name DEFAULT --rsource'']" by eval
private lemma eval_ternary_And_Unknown_Unkown:
"eval_ternary_And TernaryUnknown (eval_ternary_And TernaryUnknown tv) =
eval_ternary_And TernaryUnknown tv"
by(cases tv) (simp_all)
private lemma is_pos_Extra_alist_and:
"is_pos_Extra a ⟹ alist_and (a#as) = MatchAnd (Match (Extra (get_pos_Extra a))) (alist_and as)"
apply(cases a)
apply(simp_all add: get_pos_Extra_def is_pos_Extra_def)
apply(rename_tac e)
by(case_tac e)(simp_all)
private compress_parsed_extra_matchexpr_helper:
"ternary_ternary_eval (map_match_tac common_matcher p (alist_and (compress_parsed_extra as))) =
ternary_ternary_eval (map_match_tac common_matcher p (alist_and as))"
proof(induction as rule: compress_parsed_extra.induct)
case 1 thus ?case by(simp)
next
case (2 a1 a2) thus ?case
apply(simp add: is_pos_Extra_alist_and)
apply(cases a1)
apply(simp_all add: eval_ternary_And_Unknown_Unkown)
done
next
case 3 thus ?case by(simp)
qed
text‹This lemma justifies that it is okay to fold together the parsed unknown tokens›
compress_parsed_extra_matchexpr:
"matches (common_matcher, α) (alist_and (compress_parsed_extra as)) =
matches (common_matcher, α) (alist_and as)"
apply(simp add: fun_eq_iff)
apply(intro allI)
apply(rule matches_iff_apply_f)
apply(simp add: compress_parsed_extra_matchexpr_helper)
done
end
subsection‹L4 Ports Parser Helper›
context
begin
text‹Replace all matches on ports with the unspecified @{term 0} protocol with the given @{typ primitive_protocol}.›
private definition fill_l4_protocol_raw
:: "primitive_protocol ⇒ 'i::len common_primitive negation_type list ⇒ 'i common_primitive negation_type list"
where
"fill_l4_protocol_raw protocol ≡ NegPos_map
(λ m. case m of Src_Ports (L4Ports x pts) ⇒ if x ≠ 0 then undefined else Src_Ports (L4Ports protocol pts)
| Dst_Ports (L4Ports x pts) ⇒ if x ≠ 0 then undefined else Dst_Ports (L4Ports protocol pts)
| MultiportPorts (L4Ports x pts) ⇒ if x ≠ 0 then undefined else MultiportPorts (L4Ports protocol pts)
| Prot _ ⇒ undefined
| m ⇒ m
)"
lemma "fill_l4_protocol_raw TCP [Neg (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)), Pos (Src_Ports (L4Ports 0 [(22,22)]))] =
[Neg (Dst (IpAddrNetmask 0x7F000000 8)), Pos (Src_Ports (L4Ports 6 [(0x16, 0x16)]))]" by eval
fun fill_l4_protocol
:: "'i::len common_primitive negation_type list ⇒ 'i::len common_primitive negation_type list"
where
"fill_l4_protocol [] = []" |
"fill_l4_protocol (Pos (Prot (Proto protocol)) # ms) = Pos (Prot (Proto protocol)) # fill_l4_protocol_raw protocol ms" |
"fill_l4_protocol (Pos (Src_Ports _) # _) = undefined" |
"fill_l4_protocol (Pos (Dst_Ports _) # _) = undefined" |
"fill_l4_protocol (Pos (MultiportPorts _) # _) = undefined" |
"fill_l4_protocol (Neg (Src_Ports _) # _) = undefined" |
"fill_l4_protocol (Neg (Dst_Ports _) # _) = undefined" |
"fill_l4_protocol (Neg (MultiportPorts _) # _) = undefined" |
"fill_l4_protocol (m # ms) = m # fill_l4_protocol ms"
lemma "fill_l4_protocol [ Neg (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8))
, Neg (Prot (Proto UDP))
, Pos (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8))
, Pos (Prot (Proto TCP))
, Pos (Extra ''foo'')
, Pos (Src_Ports (L4Ports 0 [(22,22)]))
, Neg (Extra ''Bar'')] =
[ Neg (Dst (IpAddrNetmask 0x7F000000 8))
, Neg (Prot (Proto UDP))
, Pos (Src (IpAddrNetmask 0x7F000000 8))
, Pos (Prot (Proto TCP))
, Pos (Extra ''foo'')
, Pos (Src_Ports (L4Ports TCP [(0x16, 0x16)]))
, Neg (Extra ''Bar'')]" by eval
end
definition prefix_to_strange_inverse_cisco_mask:: "nat ⇒ (nat × nat × nat × nat)" where
"prefix_to_strange_inverse_cisco_mask n ≡ dotdecimal_of_ipv4addr ( (NOT (((mask n)::ipv4addr) << (32 - n))) )"
lemma "prefix_to_strange_inverse_cisco_mask 8 = (0, 255, 255, 255)" by eval
lemma "prefix_to_strange_inverse_cisco_mask 16 = (0, 0, 255, 255)" by eval
lemma "prefix_to_strange_inverse_cisco_mask 24 = (0, 0, 0, 255)" by eval
lemma "prefix_to_strange_inverse_cisco_mask 32 = (0, 0, 0, 0)" by eval
end
Theory Parser6
section‹Parser for iptables-save›
theory Parser6
imports Code_Interface
keywords "parse_ip6tables_save" :: thy_decl
begin
ML‹
fun takeWhile p xs = take_prefix p xs;
fun dropWhile p xs = drop_prefix p xs;
fun dropWhileInclusive p xs = drop 1 (dropWhile p xs)
fun split_at p xs = (takeWhile p xs, dropWhileInclusive p xs);
›
ML_val‹
split_at (fn x => x <> " ") (raw_explode "foo bar")
›
section‹An SML Parser for iptables-save›
text‹Work in Progress›
ML‹
local
fun is_start_of_table table s = s = ("*"^table);
fun is_end_of_table s = s = "COMMIT";
fun load_file (thy: theory) (path: string list) =
let val p = File.full_path (Resources.master_directory thy) (Path.make path);
val _ = "loading file "^File.platform_path p |> writeln;
in
if
not (File.exists p) orelse (File.is_dir p)
then
raise Fail "File not found"
else
File.read_lines p
end;
fun extract_table _ [] = []
| extract_table table (r::rs) = if not (is_start_of_table table r)
then
extract_table table rs
else
takeWhile (fn x => not (is_end_of_table x)) rs;
fun writenumloaded table_name table = let
val _ = "Loaded "^ Int.toString (length table) ^" lines of the "^table_name^" table" |> writeln;
in table end;
fun warn_windows_line_endings lines =
let
val warn = fn s => if String.isSuffix "\r" s
then
writeln "WARNING: windows \\r\\n line ending detected"
else
()
val _ = map warn lines
in
lines
end;
in
fun load_table table thy = load_file thy
#> warn_windows_line_endings
#> extract_table table
#> writenumloaded table;
val load_filter_table = load_table "filter";
end;
›
ML‹
local
fun collapse_quotes [] = []
| collapse_quotes ("\""::ss) = let val (quoted, rest) = split_at (fn x => x <> "\"") ss in
"\"" ^ implode quoted^"\"" :: rest end
| collapse_quotes (s::ss) = s :: collapse_quotes ss;
in
val ipt_explode = raw_explode #> collapse_quotes;
end
›
ML_val‹
ipt_explode "ad \"as das\" boo";
ipt_explode "ad \"foobar --boo boo";
ipt_explode "ent \"\\\"\" this";
ipt_explode "";
›
ML‹
datatype parsed_action_type = TypeCall | TypeGoto
datatype parsed_match_action = ParsedMatch of term
| ParsedNegatedMatch of term
| ParsedAction of parsed_action_type * string;
local
val is_whitespace = Scan.many (fn x => x = " ");
local
local
fun extract_int ss = case ss |> implode |> Int.fromString
of SOME i => i
| NONE => raise Fail "unparsable int";
fun is_iface_char x = Symbol.is_ascii x andalso
(Symbol.is_ascii_letter x orelse Symbol.is_ascii_digit x orelse x = "+"
orelse x = "*" orelse x = "." orelse x = "-")
in
fun mk_nat maxval i = if i < 0 orelse i > maxval
then
raise Fail("nat ("^Int.toString i^") must be between 0 and "^Int.toString maxval)
else (HOLogic.mk_number HOLogic.natT i);
fun ipNetmask_to_hol (ip,len) = @{const IpAddrNetmask (128)} $ mk_ipv6addr ip $ mk_nat 128 len;
fun ipRange_to_hol (ip1,ip2) = @{const IpAddrRange (128)} $ mk_ipv6addr ip1 $ mk_ipv6addr ip2;
val parser_ip_cidr = parser_ipv6 --| ($$ "/") -- (Scan.many1 Symbol.is_ascii_digit >> extract_int) >> ipNetmask_to_hol;
val parser_ip_range = parser_ipv6 --| ($$ "-") -- parser_ipv6 >> ipRange_to_hol;
val parser_ip_addr = parser_ipv6 >> (fn ip => @{const IpAddr (128)} $ mk_ipv6addr ip);
val parser_interface = Scan.many1 is_iface_char >> (implode #> (fn x => @{const Iface} $ HOLogic.mk_string x));
val parser_protocol = Scan.this_string "tcp" >> K @{term "TCP :: 8 word"}
|| Scan.this_string "udp" >> K @{term "UDP :: 8 word"}
|| (Scan.this_string "icmpv6" || Scan.this_string "ipv6-icmp")
>> K @{term "L4_Protocol.IPv6ICMP"}
|| Scan.this_string "icmp" >> K @{term "ICMP :: 8 word"}
|| Scan.this_string "esp" >> K @{term "L4_Protocol.ESP"}
|| Scan.this_string "ah" >> K @{term "L4_Protocol.AH"}
|| Scan.this_string "gre" >> K @{term "L4_Protocol.GRE"}
val parser_ctstate = Scan.this_string "NEW" >> K @{const CT_New}
|| Scan.this_string "ESTABLISHED" >> K @{const CT_Established}
|| Scan.this_string "RELATED" >> K @{const CT_Related}
|| Scan.this_string "UNTRACKED" >> K @{const CT_Untracked}
|| Scan.this_string "INVALID" >> K @{const CT_Invalid}
val parser_tcp_flag = Scan.this_string "SYN" >> K @{const TCP_SYN}
|| Scan.this_string "ACK" >> K @{const TCP_ACK}
|| Scan.this_string "FIN" >> K @{const TCP_FIN}
|| Scan.this_string "RST" >> K @{const TCP_RST}
|| Scan.this_string "URG" >> K @{const TCP_URG}
|| Scan.this_string "PSH" >> K @{const TCP_PSH}
fun parse_comma_separated_list parser = Scan.repeat (parser --| $$ ",") @@@ (parser >> (fn p => [p]))
local
val mk_port_single = mk_nat 65535 #> (fn n => @{const nat_to_16word} $ n)
val parse_port_raw = Scan.many1 Symbol.is_ascii_digit >> extract_int
fun port_tuple_warn (p1,p2) =
if p1 >= p2
then
let val _= writeln ("WARNING (in ports): "^Int.toString p1^" >= "^Int.toString p2)
in (p1, p2) end
else (p1, p2);
in
val parser_port_single_tup = (
(parse_port_raw --| $$ ":" -- parse_port_raw)
>> (port_tuple_warn #> (fn (p1,p2) => (mk_port_single p1, mk_port_single p2)))
|| (parse_port_raw >> (fn p => (mk_port_single p, mk_port_single p)))
) >> HOLogic.mk_prod
end
val parser_port_single_tup_term = parser_port_single_tup
>> (fn x => @{term "L4Ports 0"} $ HOLogic.mk_list @{typ "16 word × 16 word"} [x])
val parser_port_many1_tup = parse_comma_separated_list parser_port_single_tup
>> (fn x => @{term "L4Ports 0"} $ HOLogic.mk_list @{typ "16 word × 16 word"} x)
val parser_ctstate_set = parse_comma_separated_list parser_ctstate
>> HOLogic.mk_set @{typ "ctstate"}
val parser_tcp_flag_set = parse_comma_separated_list parser_tcp_flag
>> HOLogic.mk_set @{typ "tcp_flag"}
val parser_tcp_flags = (parser_tcp_flag_set --| $$ " " -- parser_tcp_flag_set)
>> (fn (m,c) => @{const TCP_Flags} $ m $ c)
val parser_extra = Scan.many1 (fn x => x <> " " andalso Symbol.not_eof x)
>> (implode #> HOLogic.mk_string);
end;
val eoo = Scan.ahead ($$ " " || Scan.one Symbol.is_eof);
fun parse_cmd_option_generic (d: term -> parsed_match_action) s t (parser: string list -> (term * string list)) =
Scan.finite Symbol.stopper (is_whitespace |-- Scan.this_string s |-- (parser >> (fn r => d (t $ r))) --| eoo)
fun parse_cmd_option (s: string) (t: term) (parser: string list -> (term * string list)) =
parse_cmd_option_generic ParsedMatch s t parser;
fun parse_cmd_option_negated (s: string) (t: term) (parser: string list -> (term * string list)) =
parse_cmd_option_generic ParsedNegatedMatch ("! "^s) t parser || parse_cmd_option s t parser;
fun parse_cmd_option_negated_singleton s t parser = parse_cmd_option_negated s t parser >> (fn x => [x])
fun parse_with_module_prefix (module: string) (parser: (string list -> parsed_match_action * string list)) =
(Scan.finite Symbol.stopper (is_whitespace |-- Scan.this_string module)) |-- (Scan.repeat parser)
in
val parse_ips = parse_cmd_option_negated_singleton "-s " @{const Src (128)} (parser_ip_cidr || parser_ip_addr)
|| parse_cmd_option_negated_singleton "-d " @{const Dst (128)} (parser_ip_cidr || parser_ip_addr);
val parse_iprange = parse_with_module_prefix "-m iprange "
( parse_cmd_option_negated "--src-range " @{const Src (128)} parser_ip_range
|| parse_cmd_option_negated "--dst-range " @{const Dst (128)} parser_ip_range);
val parse_iface = parse_cmd_option_negated_singleton "-i " @{const IIface (128)} parser_interface
|| parse_cmd_option_negated_singleton "-o " @{const OIface (128)} parser_interface;
val parse_protocol = parse_cmd_option_negated_singleton "-p "
@{term "(Prot ∘ Proto) :: primitive_protocol ⇒ 128 common_primitive"} parser_protocol;
val parse_tcp_options = parse_with_module_prefix "-m tcp "
( parse_cmd_option_negated "--sport " @{const Src_Ports (128)} parser_port_single_tup_term
|| parse_cmd_option_negated "--dport " @{const Dst_Ports (128)} parser_port_single_tup_term
|| parse_cmd_option_negated "--tcp-flags " @{const L4_Flags (128)} parser_tcp_flags);
val parse_multiports = parse_with_module_prefix "-m multiport "
( parse_cmd_option_negated "--sports " @{const Src_Ports (128)} parser_port_many1_tup
|| parse_cmd_option_negated "--dports " @{const Dst_Ports (128)} parser_port_many1_tup
|| parse_cmd_option_negated "--ports " @{const MultiportPorts (32)} parser_port_many1_tup);
val parse_udp_options = parse_with_module_prefix "-m udp "
( parse_cmd_option_negated "--sport " @{const Src_Ports (128)} parser_port_single_tup_term
|| parse_cmd_option_negated "--dport " @{const Dst_Ports (128)} parser_port_single_tup_term);
val parse_ctstate = parse_with_module_prefix "-m state "
(parse_cmd_option_negated "--state " @{const CT_State (128)} parser_ctstate_set)
|| parse_with_module_prefix "-m conntrack "
(parse_cmd_option_negated "--ctstate " @{const CT_State (128)} parser_ctstate_set);
val parse_unknown = (parse_cmd_option "" @{const Extra (128)} parser_extra) >> (fn x => [x]);
end;
local
fun is_target_char x = Symbol.is_ascii x andalso
(Symbol.is_ascii_letter x orelse Symbol.is_ascii_digit x orelse x = "-" orelse x = "_" orelse x = "~")
fun parse_finite_skipwhite parser = Scan.finite Symbol.stopper (is_whitespace |-- parser);
val is_icmp_type = fn x => Symbol.is_ascii_letter x orelse x = "-" orelse x = "6"
in
val parser_target = Scan.many1 is_target_char >> implode;
val parse_target_generic : (string list -> parsed_match_action * string list) = parse_finite_skipwhite
(Scan.this_string "-j " |-- (parser_target >> (fn s => ParsedAction (TypeCall, s))));
val parse_target_reject : (string list -> parsed_match_action * string list) = parse_finite_skipwhite
(Scan.this_string "-j " |-- (Scan.this_string "REJECT" >> (fn s => ParsedAction (TypeCall, s)))
--| ((Scan.this_string " --reject-with " --| Scan.many1 is_icmp_type) || Scan.this_string ""));
val parse_target_goto : (string list -> parsed_match_action * string list) = parse_finite_skipwhite
(Scan.this_string "-g " |-- (parser_target >> (fn s => let val _ = writeln ("WARNING: goto in `"^s^"'") in ParsedAction (TypeGoto, s) end)));
val parse_target : (string list -> parsed_match_action * string list) = parse_target_reject || parse_target_goto || parse_target_generic;
end;
in
val parse_table_append : (string list -> (string * string list)) = Scan.this_string "-A " |-- parser_target --| is_whitespace;
val option_parser : (string list -> (parsed_match_action list) * string list) =
Scan.recover (parse_ips || parse_iprange
|| parse_iface
|| parse_protocol
|| parse_tcp_options || parse_udp_options || parse_multiports
|| parse_ctstate
|| parse_target >> (fn x => [x])) (K parse_unknown);
local
val custom_chain_decl_parser = ($$ ":") |-- parser_target --| Scan.this_string " - " #> fst;
val builtin_chain_decl_parser = ($$ ":") |--
(Scan.this_string "INPUT" || Scan.this_string "FORWARD" || Scan.this_string "OUTPUT" || Scan.this_string "PREROUTING") --|
($$ " ") -- (Scan.this_string "ACCEPT" || Scan.this_string "DROP") --| ($$ " ") #> fst;
val wrap_builtin_chain = (fn (name, policy) => (name, SOME policy));
val wrap_custom_chain = (fn name => (name, NONE));
in
val chain_decl_parser : (string list -> string * string option) =
Scan.recover (builtin_chain_decl_parser #> wrap_builtin_chain) (K (custom_chain_decl_parser #> wrap_custom_chain));
end
end;
›
ML‹
local
fun concat [] = []
| concat (x :: xs) = x @ concat xs;
in
fun Scan_cons_repeat (parser: ('a -> 'b list * 'a)) (s: 'a) : ('b list * 'a) =
let val (x, rest) = Scan.repeat parser s in (concat x, rest) end;
end
›
ML_val‹(Scan_cons_repeat option_parser) (ipt_explode "-i lup -j net-fw")›
ML_val‹(Scan_cons_repeat option_parser) (ipt_explode "")›
ML_val‹(Scan_cons_repeat option_parser) (ipt_explode "-i lup foo")›
ML_val‹(Scan_cons_repeat option_parser) (ipt_explode "-m tcp --dport 22 --sport 88")›
ML_val‹(Scan_cons_repeat option_parser) (ipt_explode "-j LOG --log-prefix \"Shorewall:INPUT:REJECT:\" --log-level 6")›
ML_val‹
val (x, rest) = (Scan_cons_repeat option_parser) (ipt_explode "-d 0.31.123.213/11. --foo_bar \"he he\" -f -i eth0+ -s 0.31.123.213/21 moreextra -j foobar --log");
map (fn p => case p of ParsedMatch t => type_of t | ParsedAction (_,_) => dummyT) x;
map (fn p => case p of ParsedMatch t => Pretty.writeln (Syntax.pretty_term @{context} t) | ParsedAction (_,a) => writeln ("action: "^a)) x;
›
ML‹
local
fun parse_rule_options (s: string list) : parsed_match_action list = let
val (parsed, rest) = (case try (Scan.catch (Scan_cons_repeat option_parser)) s
of SOME x => x
| NONE => raise Fail "scanning")
in
if rest <> []
then
raise Fail ("Unparsed: `"^implode rest^"'")
else
parsed
end
handle Fail m => raise Fail ("parse_rule_options: "^m^" for rule `"^implode s^"'");
fun get_target (ps : parsed_match_action list) : (parsed_action_type * string) option = let
val actions = List.mapPartial (fn p => case p of ParsedAction a => SOME a
| _ => NONE) ps
in case actions of [] => NONE
| [action] => SOME action
| _ => raise Fail "there can be at most one target"
end;
val get_matches : (parsed_match_action list -> term) =
List.mapPartial (fn p => case p of
ParsedMatch m => SOME (@{const Pos ("128 common_primitive")} $ m)
| ParsedNegatedMatch m => SOME (@{const Neg ("128 common_primitive")} $ m)
| ParsedAction _ => NONE)
#> HOLogic.mk_list @{typ "128 common_primitive negation_type"};
fun parse_rule (s: string) : (string * (parsed_action_type * string) option * term) = let
val (chainname, rest) =
(case try (ipt_explode #> Scan.finite Symbol.stopper parse_table_append) s
of SOME x => x
| NONE => raise Fail ("parse_rule: parse_table_append: "^s));
val parsed = parse_rule_options rest
in (chainname, get_target parsed, get_matches parsed) end;
in
fun rule_type_partition (rs : string list) : ((string * string option) list * (string * (parsed_action_type * string) option * term) list) =
let
val (chain_decl, rules) = List.partition (String.isPrefix ":") rs
in
if not (List.all (String.isPrefix "-A") rules)
then
raise Fail "could not partition rules"
else
let val parsed_chain_decls = (case try (map (ipt_explode #> chain_decl_parser)) chain_decl
of SOME x => x
| NONE => raise Fail ("could not parse chain declarations: "^implode chain_decl));
val parsed_rules = map parse_rule rules;
val _ = "Parsed "^ Int.toString (length parsed_chain_decls) ^" chain declarations" |> writeln;
val _ = "Parsed "^ Int.toString (length parsed_rules) ^" rules" |> writeln;
in (parsed_chain_decls, parsed_rules) end
end
fun get_chain_decls_policy (ls: ((string * string option) list * (string * (parsed_action_type * string) option * term) list)) = fst ls
fun get_parsed_rules (ls: ((string * string option) list * (string * (parsed_action_type * string) option * term) list)) = snd ls
val filter_chain_decls_names_only :
((string * string option) list * (string * (parsed_action_type * string) option * term) list) ->
(string list * (string * (parsed_action_type * string) option * term) list) = (fn (a,b) => (map fst a, b))
end;
›
ML‹
structure FirewallTable = Table(type key = string; val ord = Library.string_ord);
type firewall_table = term list FirewallTable.table;
local
fun FirewallTable_init chain_decls : firewall_table = FirewallTable.empty
|> fold (fn entry => fn accu => FirewallTable.update_new (entry, []) accu) chain_decls;
fun hacky_hack t =
@{const alist_and' ("128 common_primitive")} $ (@{const fill_l4_protocol (128)} $ (@{const compress_parsed_extra (128)} $ t))
fun mk_MatchExpr t = if fastype_of t <> @{typ "128 common_primitive negation_type list"}
then
raise Fail "Type Error"
else
hacky_hack t;
fun mk_Rule_help t a = let val r = @{const Rule ("128 common_primitive")} $ (mk_MatchExpr t) $ a in
if fastype_of r <> @{typ "128 common_primitive rule"} then raise Fail "Type error in mk_Rule_help"
else r end;
fun append table chain rule = case FirewallTable.lookup table chain
of NONE => raise Fail ("uninitialized cahin: "^chain)
| SOME rules => FirewallTable.update (chain, rules@[rule]) table
fun mk_Rule (tbl: firewall_table) (chain: string, target : (parsed_action_type * string) option, t : term) =
if not (FirewallTable.defined tbl chain)
then
raise Fail ("undefined chain to be appended: "^chain)
else case target
of NONE => mk_Rule_help t @{const action.Empty}
| SOME (TypeCall, "ACCEPT") => mk_Rule_help t @{const action.Accept}
| SOME (TypeCall, "DROP") => mk_Rule_help t @{const action.Drop}
| SOME (TypeCall, "REJECT") => mk_Rule_help t @{const action.Reject}
| SOME (TypeCall, "LOG") => mk_Rule_help t @{const action.Log}
| SOME (TypeCall, "RETURN") => mk_Rule_help t @{const action.Return}
| SOME (TypeCall, custom) => if not (FirewallTable.defined tbl custom)
then
raise Fail ("unknown action: "^custom)
else
mk_Rule_help t (@{const action.Call} $ HOLogic.mk_string custom)
| SOME (TypeGoto, "ACCEPT") => raise Fail "Unexpected"
| SOME (TypeGoto, "DROP") => raise Fail "Unexpected"
| SOME (TypeGoto, "REJECT") => raise Fail "Unexpected"
| SOME (TypeGoto, "LOG") => raise Fail "Unexpected"
| SOME (TypeGoto, "RETURN") => raise Fail "Unexpected"
| SOME (TypeGoto, custom) => if not (FirewallTable.defined tbl custom)
then
raise Fail ("unknown action: "^custom)
else
mk_Rule_help t (@{const action.Goto} $ HOLogic.mk_string custom);
in
local
fun append_rule (tbl: firewall_table) (chain: string, target : (parsed_action_type * string) option, t : term) = append tbl chain (mk_Rule tbl (chain, target, t))
in
fun make_firewall_table (parsed_chain_decls : string list, parsed_rules : (string * (parsed_action_type * string) option * term) list) =
fold (fn rule => fn accu => append_rule accu rule) parsed_rules (FirewallTable_init parsed_chain_decls);
end
end
›
ML‹
fun mk_Ruleset (tbl: firewall_table) = FirewallTable.dest tbl
|> map (fn (k,v) => HOLogic.mk_prod (HOLogic.mk_string k, HOLogic.mk_list @{typ "128 common_primitive rule"} v))
|> HOLogic.mk_list @{typ "string × 128 common_primitive rule list"}
›
ML‹
local
fun default_policy_action_to_term "ACCEPT" = @{const "action.Accept"}
| default_policy_action_to_term "DROP" = @{const "action.Drop"}
| default_policy_action_to_term a = raise Fail ("Not a valid default policy `"^a^"'")
in
fun preparedefault_policies [] = []
| preparedefault_policies ((chain_name, SOME default_policy)::ls) =
(chain_name, default_policy_action_to_term default_policy) :: preparedefault_policies ls
| preparedefault_policies ((_, NONE)::ls) = preparedefault_policies ls
end
›
ML‹
fun trace_timing (printstr : string) (f : 'a -> 'b) (a : 'a) : 'b =
let val t0 = Time.now(); in
let val result = f a; in
let val t1= Time.now(); in
let val _ = writeln(String.concat [printstr^" (", Time.toString(Time.-(t1,t0)), " seconds)"]) in
result
end end end end;
fun simplify_code ctxt = let val _ = writeln "unfolding (this may take a while) ..." in
trace_timing "Simplified term" (Code_Evaluation.dynamic_value_strict ctxt)
end
fun certify_term ctxt t = trace_timing "Certified term" (Thm.cterm_of ctxt) t
›
ML_val‹
fun parse_iptables_save_global thy (file: string list) : term =
load_filter_table thy file
|> rule_type_partition
|> filter_chain_decls_names_only
|> make_firewall_table
|> mk_Ruleset
|> simplify_code @{context}
›
ML‹
local
fun define_const t name lthy = let
val binding_name = Thm.def_binding name
val _ = writeln ("Defining constant `" ^ Binding.name_of binding_name ^ "'");
in
lthy
|> Proof_Context.set_stmt false
|> Local_Theory.define ((name, NoSyn), ((binding_name, @{attributes [code]}), t)) |> #2
end;
fun print_default_policies (ps: (string * term) list) = let
val _ = ps |> map (fn (name, _) =>
if name <> "INPUT" andalso name <> "FORWARD" andalso name <> "OUTPUT"
then
writeln ("WARNING: the chain `"^name^"' is not a built-in chain of the filter table")
else ())
in ps end;
fun sanity_check_ruleset ctxt t = let
val check = Code_Evaluation.dynamic_value_strict ctxt (@{const sanity_wf_ruleset ("128 common_primitive")} $ t)
in
if check <> @{term "True"} then raise ERROR "sanity_wf_ruleset failed" else t
end;
in
fun parse_iptables_save table name path lthy =
let
val prepared = path
|> load_table table (Proof_Context.theory_of lthy)
|> rule_type_partition
val firewall = prepared
|> filter_chain_decls_names_only
|> make_firewall_table
|> mk_Ruleset
|> simplify_code lthy
|> trace_timing "checked sanity with sanity_wf_ruleset" (sanity_check_ruleset lthy)
val default_policis = prepared
|> get_chain_decls_policy
|> preparedefault_policies
|> print_default_policies
in
lthy
|> define_const firewall name
|> fold (fn (chain_name, policy) =>
define_const policy (Binding.name (Binding.name_of name ^ "_" ^ chain_name ^ "_default_policy")))
default_policis
end
end
›
ML‹
Outer_Syntax.local_theory @{command_keyword parse_ip6tables_save}
"load a file generated by iptables-save and make the firewall definition available as isabelle term"
(Parse.binding --| @{keyword "="} -- Scan.repeat1 Parse.path >>
(fn (binding, paths) => parse_iptables_save "filter" binding paths))
›
end
Theory No_Spoof_Embeddings
theory No_Spoof_Embeddings
imports Semantics_Embeddings
"Primitive_Matchers/No_Spoof"
begin
section‹Spoofing protection in Ternary Semantics implies Spoofing protection Boolean Semantics›
text‹If @{const no_spoofing} is shown in the ternary semantics, it implies that no spoofing
is possible in the Boolean semantics with magic oracle.
We only assume that the oracle agrees with the @{const common_matcher} on the not-unknown parts.›
lemma approximating_imp_booloan_semantics_nospoofing:
assumes "matcher_agree_on_exact_matches γ common_matcher"
and "simple_ruleset rs"
and no_spoofing: "no_spoofing TYPE('pkt_ext) ipassmt rs"
shows "∀ iface ∈ dom ipassmt. ∀p::('i::len,'pkt_ext) tagged_packet_scheme.
(Γ,γ,p⦇p_iiface:=iface_sel iface⦈⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow) ⟶
p_src p ∈ (ipcidr_union_set (set (the (ipassmt iface))))"
unfolding no_spoofing_def
proof(intro ballI allI impI)
fix iface p
assume i: "iface ∈ dom ipassmt"
and a: "Γ,γ,p⦇p_iiface := iface_sel iface⦈⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow"
from no_spoofing[unfolded no_spoofing_def] i have no_spoofing':
"(common_matcher, in_doubt_allow),p⦇p_iiface := iface_sel iface⦈⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ⟶
p_src p ∈ ipcidr_union_set (set (the (ipassmt iface)))" by blast
from assms simple_imp_good_ruleset FinalAllows_subseteq_in_doubt_allow[where rs=rs] have
"{p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow} ⊆ {p. (common_matcher, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow}"
by blast
with a have "(common_matcher, in_doubt_allow),p⦇p_iiface := iface_sel iface⦈⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow" by blast
with no_spoofing' show "p_src p ∈ ipcidr_union_set (set (the (ipassmt iface)))"by blast
qed
corollary
assumes "matcher_agree_on_exact_matches γ common_matcher" and "simple_ruleset rs"
and no_spoofing: "no_spoofing TYPE('pkt_ext) ipassmt rs" and "iface ∈ dom ipassmt"
shows "{p_src p | p :: ('i::len,'pkt_ext) tagged_packet_scheme. (Γ,γ,p⦇p_iiface:=iface_sel iface⦈⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow)} ⊆
ipcidr_union_set (set (the (ipassmt iface)))"
using approximating_imp_booloan_semantics_nospoofing[OF assms(1) assms(2) assms(3), where Γ=Γ]
using assms(4) by blast
corollary no_spoofing_executable_set:
assumes "matcher_agree_on_exact_matches γ common_matcher"
and "simple_ruleset rs"
and "∀r∈set rs. normalized_nnf_match (get_match r)"
and no_spoofing_executable: "∀iface ∈ dom ipassmt. no_spoofing_iface iface ipassmt rs"
and "iface ∈ dom ipassmt"
shows "{p_src p | p :: ('i::len,'pkt_ext) tagged_packet_scheme. (Γ,γ,p⦇p_iiface:=iface_sel iface⦈⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow)} ⊆
ipcidr_union_set (set (the (ipassmt iface)))"
proof -
{ assume no_spoofing: "no_spoofing TYPE('pkt_ext) ipassmt rs"
have "{p_src p | p :: ('i,'pkt_ext) tagged_packet_scheme. (Γ,γ,p⦇p_iiface:=iface_sel iface⦈⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow)} ⊆
ipcidr_union_set (set (the (ipassmt iface)))"
using approximating_imp_booloan_semantics_nospoofing[OF assms(1) assms(2) no_spoofing, where Γ=Γ]
using assms(5) by blast
}
with no_spoofing_iface[OF assms(2) assms(3) no_spoofing_executable] show ?thesis by blast
qed
corollary no_spoofing_executable_set_preprocessed:
fixes ipassmt :: "'i::len ipassignment"
defines "preprocess rs ≡ upper_closure (packet_assume_new rs)"
and "newpkt p ≡ match_tcp_flags ipt_tcp_syn (p_tcp_flags p) ∧ p_tag_ctstate p = CT_New"
assumes "matcher_agree_on_exact_matches γ common_matcher"
and simplers: "simple_ruleset rs"
and no_spoofing_executable: "∀iface ∈ dom ipassmt. no_spoofing_iface iface ipassmt (preprocess rs)"
and "iface ∈ dom ipassmt"
shows "{p_src p | p :: ('i::len,'pkt_ext) tagged_packet_scheme. newpkt p ∧ Γ,γ,p⦇p_iiface:=iface_sel iface⦈⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow} ⊆
ipcidr_union_set (set (the (ipassmt iface)))"
proof -
have newpktD: "newpkt p ⟹ newpkt (p⦇p_iiface := iface_sel iface⦈)" for p
by(simp add: newpkt_def)
from packet_assume_new_simple_ruleset[OF simplers] have s1: "simple_ruleset (packet_assume_new rs)" .
from transform_upper_closure(2)[OF s1] have s2: "simple_ruleset (upper_closure (packet_assume_new rs))" .
hence s2': "simple_ruleset (preprocess rs)" unfolding preprocess_def by simp
have "∀r∈set (preprocess rs). normalized_nnf_match (get_match r)"
unfolding preprocess_def
using transform_upper_closure(3)[OF s1] by simp
from no_spoofing_iface[OF s2' this no_spoofing_executable] have nospoof: "no_spoofing TYPE('a) ipassmt (preprocess rs)" .
from assms(3) have 1: "{p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow ∧ newpkt p} ⊆
{p. (common_matcher, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
apply(drule_tac rs=rs and Γ=Γ in FinalAllows_subseteq_in_doubt_allow)
using simple_imp_good_ruleset assms(4) apply blast
by blast
have 2: "{p. (common_matcher, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p} ⊆
{p. (common_matcher, in_doubt_allow),p⊢ ⟨preprocess rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}"
unfolding newpkt_def preprocess_def
apply(subst transform_upper_closure(1)[OF s1])
apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s1]])
apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]])
using packet_assume_new newpkt_def by force
from 1 2 have "{p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow ∧ newpkt p} ⊆
{p. (common_matcher, in_doubt_allow),p⊢ ⟨preprocess rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}" by simp
hence p: "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow ∧ newpkt p ⟹
(common_matcher, in_doubt_allow),p⊢ ⟨preprocess rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p" for p by blast
have x: "{p_src p | p . newpkt p ∧ (Γ,γ,p⦇p_iiface:=iface_sel iface⦈⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow)} ⊆
{p_src p | p . newpkt p ∧ (common_matcher, in_doubt_allow),p⦇p_iiface:=iface_sel iface⦈⊢ ⟨preprocess rs, Undecided⟩ ⇒⇩α Decision FinalAllow}"
apply(safe, rename_tac p)
apply(drule newpktD)
apply(rule_tac x="p⦇p_iiface := iface_sel iface⦈" in exI)
using p by simp
note[[show_types]]
with nospoof have y:
"{p_src p | p :: ('i::len,'pkt_ext) tagged_packet_scheme. newpkt p ∧ (common_matcher, in_doubt_allow),p⦇p_iiface:=iface_sel iface⦈⊢ ⟨preprocess rs, Undecided⟩ ⇒⇩α Decision FinalAllow}
⊆ ipcidr_union_set (set (the (ipassmt iface)))"
apply(simp add: no_spoofing_def)
by(blast dest: bspec[OF _ assms(6)])
from x y show ?thesis by simp
qed
end
Theory Parser
section‹Parser for iptables-save›
theory Parser
imports Code_Interface
keywords "parse_iptables_save" :: thy_decl
begin
ML‹
fun takeWhile p xs = take_prefix p xs;
fun dropWhile p xs = drop_prefix p xs;
fun dropWhileInclusive p xs = drop 1 (dropWhile p xs)
fun split_at p xs = (takeWhile p xs, dropWhileInclusive p xs);
›
ML_val‹
split_at (fn x => x <> " ") (raw_explode "foo bar")
›
section‹An SML Parser for iptables-save›
text‹Work in Progress›
ML‹
local
fun is_start_of_table table s = s = ("*"^table);
fun is_end_of_table s = s = "COMMIT";
fun load_file (thy: theory) (path: string list) =
let val p = File.full_path (Resources.master_directory thy) (Path.make path);
val _ = "loading file "^File.platform_path p |> writeln;
in
if
not (File.exists p) orelse (File.is_dir p)
then
raise Fail "File not found"
else
File.read_lines p
end;
fun extract_table _ [] = []
| extract_table table (r::rs) = if not (is_start_of_table table r)
then
extract_table table rs
else
takeWhile (fn x => not (is_end_of_table x)) rs;
fun writenumloaded table_name table = let
val _ = "Loaded "^ Int.toString (length table) ^" lines of the "^table_name^" table" |> writeln;
in table end;
fun warn_windows_line_endings lines =
let
val warn = fn s => if String.isSuffix "\r" s
then
writeln "WARNING: windows \\r\\n line ending detected"
else
()
val _ = map warn lines
in
lines
end;
in
fun load_table table thy = load_file thy
#> warn_windows_line_endings
#> extract_table table
#> writenumloaded table;
val load_filter_table = load_table "filter";
end;
›
ML‹
local
fun collapse_quotes [] = []
| collapse_quotes ("\""::ss) = let val (quoted, rest) = split_at (fn x => x <> "\"") ss in
"\"" ^ implode quoted^"\"" :: rest end
| collapse_quotes (s::ss) = s :: collapse_quotes ss;
in
val ipt_explode = raw_explode #> collapse_quotes;
end
›
ML_val‹
ipt_explode "ad \"as das\" boo";
ipt_explode "ad \"foobar --boo boo";
ipt_explode "ent \"\\\"\" this";
ipt_explode "";
›
ML‹
datatype parsed_action_type = TypeCall | TypeGoto
datatype parsed_match_action = ParsedMatch of term
| ParsedNegatedMatch of term
| ParsedAction of parsed_action_type * string;
local
val is_whitespace = Scan.many (fn x => x = " ");
local
local
fun extract_int ss = case ss |> implode |> Int.fromString
of SOME i => i
| NONE => raise Fail "unparsable int";
fun is_iface_char x = Symbol.is_ascii x andalso
(Symbol.is_ascii_letter x orelse Symbol.is_ascii_digit x orelse x = "+"
orelse x = "*" orelse x = "." orelse x = "-")
in
fun mk_nat maxval i = if i < 0 orelse i > maxval
then
raise Fail("nat ("^Int.toString i^") must be between 0 and "^Int.toString maxval)
else (HOLogic.mk_number HOLogic.natT i);
fun ipNetmask_to_hol (ip,len) = @{const IpAddrNetmask (32)} $ mk_ipv4addr ip $ mk_nat 32 len;
fun ipRange_to_hol (ip1,ip2) = @{const IpAddrRange (32)} $ mk_ipv4addr ip1 $ mk_ipv4addr ip2;
val parser_ip_cidr = parser_ipv4 --| ($$ "/") -- (Scan.many1 Symbol.is_ascii_digit >> extract_int) >> ipNetmask_to_hol;
val parser_ip_range = parser_ipv4 --| ($$ "-") -- parser_ipv4 >> ipRange_to_hol;
val parser_ip_addr = parser_ipv4 >> (fn ip => @{const IpAddr (32)} $ mk_ipv4addr ip);
val parser_interface = Scan.many1 is_iface_char >> (implode #> (fn x => @{const Iface} $ HOLogic.mk_string x));
val parser_protocol = Scan.this_string "tcp" >> K @{term "TCP :: 8 word"}
|| Scan.this_string "udp" >> K @{term "UDP :: 8 word"}
|| (Scan.this_string "icmpv6" || Scan.this_string "ipv6-icmp")
>> K @{term "L4_Protocol.IPv6ICMP"}
|| Scan.this_string "icmp" >> K @{term "ICMP :: 8 word"}
|| Scan.this_string "esp" >> K @{term "L4_Protocol.ESP"}
|| Scan.this_string "ah" >> K @{term "L4_Protocol.AH"}
|| Scan.this_string "gre" >> K @{term "L4_Protocol.GRE"}
val parser_ctstate = Scan.this_string "NEW" >> K @{const CT_New}
|| Scan.this_string "ESTABLISHED" >> K @{const CT_Established}
|| Scan.this_string "RELATED" >> K @{const CT_Related}
|| Scan.this_string "UNTRACKED" >> K @{const CT_Untracked}
|| Scan.this_string "INVALID" >> K @{const CT_Invalid}
val parser_tcp_flag = Scan.this_string "SYN" >> K @{const TCP_SYN}
|| Scan.this_string "ACK" >> K @{const TCP_ACK}
|| Scan.this_string "FIN" >> K @{const TCP_FIN}
|| Scan.this_string "RST" >> K @{const TCP_RST}
|| Scan.this_string "URG" >> K @{const TCP_URG}
|| Scan.this_string "PSH" >> K @{const TCP_PSH}
fun parse_comma_separated_list parser = Scan.repeat (parser --| $$ ",") @@@ (parser >> (fn p => [p]))
local
val mk_port_single = mk_nat 65535 #> (fn n => @{const nat_to_16word} $ n)
val parse_port_raw = Scan.many1 Symbol.is_ascii_digit >> extract_int
fun port_tuple_warn (p1,p2) =
if p1 >= p2
then
let val _= writeln ("WARNING (in ports): "^Int.toString p1^" >= "^Int.toString p2)
in (p1, p2) end
else (p1, p2);
in
val parser_port_single_tup = (
(parse_port_raw --| $$ ":" -- parse_port_raw)
>> (port_tuple_warn #> (fn (p1,p2) => (mk_port_single p1, mk_port_single p2)))
|| (parse_port_raw >> (fn p => (mk_port_single p, mk_port_single p)))
) >> HOLogic.mk_prod
end
val parser_port_single_tup_term = parser_port_single_tup
>> (fn x => @{term "L4Ports 0"} $ HOLogic.mk_list @{typ "16 word × 16 word"} [x])
val parser_port_many1_tup = parse_comma_separated_list parser_port_single_tup
>> (fn x => @{term "L4Ports 0"} $ HOLogic.mk_list @{typ "16 word × 16 word"} x)
val parser_ctstate_set = parse_comma_separated_list parser_ctstate
>> HOLogic.mk_set @{typ "ctstate"}
val parser_tcp_flag_set = parse_comma_separated_list parser_tcp_flag
>> HOLogic.mk_set @{typ "tcp_flag"}
val parser_tcp_flags = (parser_tcp_flag_set --| $$ " " -- parser_tcp_flag_set)
>> (fn (m,c) => @{const TCP_Flags} $ m $ c)
val parser_extra = Scan.many1 (fn x => x <> " " andalso Symbol.not_eof x)
>> (implode #> HOLogic.mk_string);
end;
val eoo = Scan.ahead ($$ " " || Scan.one Symbol.is_eof);
fun parse_cmd_option_generic (d: term -> parsed_match_action) s t (parser: string list -> (term * string list)) =
Scan.finite Symbol.stopper (is_whitespace |-- Scan.this_string s |-- (parser >> (fn r => d (t $ r))) --| eoo)
fun parse_cmd_option (s: string) (t: term) (parser: string list -> (term * string list)) =
parse_cmd_option_generic ParsedMatch s t parser;
fun parse_cmd_option_negated (s: string) (t: term) (parser: string list -> (term * string list)) =
parse_cmd_option_generic ParsedNegatedMatch ("! "^s) t parser || parse_cmd_option s t parser;
fun parse_cmd_option_negated_singleton s t parser = parse_cmd_option_negated s t parser >> (fn x => [x])
fun parse_with_module_prefix (module: string) (parser: (string list -> parsed_match_action * string list)) =
(Scan.finite Symbol.stopper (is_whitespace |-- Scan.this_string module)) |-- (Scan.repeat parser)
in
val parse_ips = parse_cmd_option_negated_singleton "-s " @{const Src (32)} (parser_ip_cidr || parser_ip_addr)
|| parse_cmd_option_negated_singleton "-d " @{const Dst (32)} (parser_ip_cidr || parser_ip_addr);
val parse_iprange = parse_with_module_prefix "-m iprange "
( parse_cmd_option_negated "--src-range " @{const Src (32)} parser_ip_range
|| parse_cmd_option_negated "--dst-range " @{const Dst (32)} parser_ip_range);
val parse_iface = parse_cmd_option_negated_singleton "-i " @{const IIface (32)} parser_interface
|| parse_cmd_option_negated_singleton "-o " @{const OIface (32)} parser_interface;
val parse_protocol = parse_cmd_option_negated_singleton "-p "
@{term "(Prot ∘ Proto) :: primitive_protocol ⇒ 32 common_primitive"} parser_protocol;
val parse_tcp_options = parse_with_module_prefix "-m tcp "
( parse_cmd_option_negated "--sport " @{const Src_Ports (32)} parser_port_single_tup_term
|| parse_cmd_option_negated "--dport " @{const Dst_Ports (32)} parser_port_single_tup_term
|| parse_cmd_option_negated "--tcp-flags " @{const L4_Flags (32)} parser_tcp_flags);
val parse_multiports = parse_with_module_prefix "-m multiport "
( parse_cmd_option_negated "--sports " @{const Src_Ports (32)} parser_port_many1_tup
|| parse_cmd_option_negated "--dports " @{const Dst_Ports (32)} parser_port_many1_tup
|| parse_cmd_option_negated "--ports " @{const MultiportPorts (32)} parser_port_many1_tup);
val parse_udp_options = parse_with_module_prefix "-m udp "
( parse_cmd_option_negated "--sport " @{const Src_Ports (32)} parser_port_single_tup_term
|| parse_cmd_option_negated "--dport " @{const Dst_Ports (32)} parser_port_single_tup_term);
val parse_ctstate = parse_with_module_prefix "-m state "
(parse_cmd_option_negated "--state " @{const CT_State (32)} parser_ctstate_set)
|| parse_with_module_prefix "-m conntrack "
(parse_cmd_option_negated "--ctstate " @{const CT_State (32)} parser_ctstate_set);
val parse_unknown = (parse_cmd_option "" @{const Extra (32)} parser_extra) >> (fn x => [x]);
end;
local
fun is_target_char x = Symbol.is_ascii x andalso
(Symbol.is_ascii_letter x orelse Symbol.is_ascii_digit x orelse x = "-" orelse x = "_" orelse x = "~")
fun parse_finite_skipwhite parser = Scan.finite Symbol.stopper (is_whitespace |-- parser);
val is_icmp_type = fn x => Symbol.is_ascii_letter x orelse x = "-" orelse x = "6"
in
val parser_target = Scan.many1 is_target_char >> implode;
val parse_target_generic : (string list -> parsed_match_action * string list) = parse_finite_skipwhite
(Scan.this_string "-j " |-- (parser_target >> (fn s => ParsedAction (TypeCall, s))));
val parse_target_reject : (string list -> parsed_match_action * string list) = parse_finite_skipwhite
(Scan.this_string "-j " |-- (Scan.this_string "REJECT" >> (fn s => ParsedAction (TypeCall, s)))
--| ((Scan.this_string " --reject-with " --| Scan.many1 is_icmp_type) || Scan.this_string ""));
val parse_target_goto : (string list -> parsed_match_action * string list) = parse_finite_skipwhite
(Scan.this_string "-g " |-- (parser_target >> (fn s => let val _ = writeln ("WARNING: goto in `"^s^"'") in ParsedAction (TypeGoto, s) end)));
val parse_target : (string list -> parsed_match_action * string list) = parse_target_reject || parse_target_goto || parse_target_generic;
end;
in
val parse_table_append : (string list -> (string * string list)) = Scan.this_string "-A " |-- parser_target --| is_whitespace;
val option_parser : (string list -> (parsed_match_action list) * string list) =
Scan.recover (parse_ips || parse_iprange
|| parse_iface
|| parse_protocol
|| parse_tcp_options || parse_udp_options || parse_multiports
|| parse_ctstate
|| parse_target >> (fn x => [x])) (K parse_unknown);
local
val custom_chain_decl_parser = ($$ ":") |-- parser_target --| Scan.this_string " - " #> fst;
val builtin_chain_decl_parser = ($$ ":") |--
(Scan.this_string "INPUT" || Scan.this_string "FORWARD" || Scan.this_string "OUTPUT" || Scan.this_string "PREROUTING") --|
($$ " ") -- (Scan.this_string "ACCEPT" || Scan.this_string "DROP") --| ($$ " ") #> fst;
val wrap_builtin_chain = (fn (name, policy) => (name, SOME policy));
val wrap_custom_chain = (fn name => (name, NONE));
in
val chain_decl_parser : (string list -> string * string option) =
Scan.recover (builtin_chain_decl_parser #> wrap_builtin_chain) (K (custom_chain_decl_parser #> wrap_custom_chain));
end
end;
›
ML‹
local
fun concat [] = []
| concat (x :: xs) = x @ concat xs;
in
fun Scan_cons_repeat (parser: ('a -> 'b list * 'a)) (s: 'a) : ('b list * 'a) =
let val (x, rest) = Scan.repeat parser s in (concat x, rest) end;
end
›
ML_val‹(Scan_cons_repeat option_parser) (ipt_explode "-i lup -j net-fw")›
ML_val‹(Scan_cons_repeat option_parser) (ipt_explode "")›
ML_val‹(Scan_cons_repeat option_parser) (ipt_explode "-i lup foo")›
ML_val‹(Scan_cons_repeat option_parser) (ipt_explode "-m tcp --dport 22 --sport 88")›
ML_val‹(Scan_cons_repeat option_parser) (ipt_explode "-j LOG --log-prefix \"Shorewall:INPUT:REJECT:\" --log-level 6")›
ML_val‹
val (x, rest) = (Scan_cons_repeat option_parser) (ipt_explode "-d 0.31.123.213/11. --foo_bar \"he he\" -f -i eth0+ -s 0.31.123.213/21 moreextra -j foobar --log");
map (fn p => case p of ParsedMatch t => type_of t | ParsedAction (_,_) => dummyT) x;
map (fn p => case p of ParsedMatch t => Pretty.writeln (Syntax.pretty_term @{context} t) | ParsedAction (_,a) => writeln ("action: "^a)) x;
›
ML‹
local
fun parse_rule_options (s: string list) : parsed_match_action list = let
val (parsed, rest) = (case try (Scan.catch (Scan_cons_repeat option_parser)) s
of SOME x => x
| NONE => raise Fail "scanning")
in
if rest <> []
then
raise Fail ("Unparsed: `"^implode rest^"'")
else
parsed
end
handle Fail m => raise Fail ("parse_rule_options: "^m^" for rule `"^implode s^"'");
fun get_target (ps : parsed_match_action list) : (parsed_action_type * string) option = let
val actions = List.mapPartial (fn p => case p of ParsedAction a => SOME a
| _ => NONE) ps
in case actions of [] => NONE
| [action] => SOME action
| _ => raise Fail "there can be at most one target"
end;
val get_matches : (parsed_match_action list -> term) =
List.mapPartial (fn p => case p of
ParsedMatch m => SOME (@{const Pos ("32 common_primitive")} $ m)
| ParsedNegatedMatch m => SOME (@{const Neg ("32 common_primitive")} $ m)
| ParsedAction _ => NONE)
#> HOLogic.mk_list @{typ "32 common_primitive negation_type"};
fun parse_rule (s: string) : (string * (parsed_action_type * string) option * term) = let
val (chainname, rest) =
(case try (ipt_explode #> Scan.finite Symbol.stopper parse_table_append) s
of SOME x => x
| NONE => raise Fail ("parse_rule: parse_table_append: "^s));
val parsed = parse_rule_options rest
in (chainname, get_target parsed, get_matches parsed) end;
in
fun rule_type_partition (rs : string list) : ((string * string option) list * (string * (parsed_action_type * string) option * term) list) =
let
val (chain_decl, rules) = List.partition (String.isPrefix ":") rs
in
if not (List.all (String.isPrefix "-A") rules)
then
raise Fail "could not partition rules"
else
let val parsed_chain_decls = (case try (map (ipt_explode #> chain_decl_parser)) chain_decl
of SOME x => x
| NONE => raise Fail ("could not parse chain declarations: "^implode chain_decl));
val parsed_rules = map parse_rule rules;
val _ = "Parsed "^ Int.toString (length parsed_chain_decls) ^" chain declarations" |> writeln;
val _ = "Parsed "^ Int.toString (length parsed_rules) ^" rules" |> writeln;
in (parsed_chain_decls, parsed_rules) end
end
fun get_chain_decls_policy (ls: ((string * string option) list * (string * (parsed_action_type * string) option * term) list)) = fst ls
fun get_parsed_rules (ls: ((string * string option) list * (string * (parsed_action_type * string) option * term) list)) = snd ls
val filter_chain_decls_names_only :
((string * string option) list * (string * (parsed_action_type * string) option * term) list) ->
(string list * (string * (parsed_action_type * string) option * term) list) = (fn (a,b) => (map fst a, b))
end;
›
ML‹
structure FirewallTable = Table(type key = string; val ord = Library.string_ord);
type firewall_table = term list FirewallTable.table;
local
fun FirewallTable_init chain_decls : firewall_table = FirewallTable.empty
|> fold (fn entry => fn accu => FirewallTable.update_new (entry, []) accu) chain_decls;
fun hacky_hack t =
@{const alist_and' ("32 common_primitive")} $ (@{const fill_l4_protocol (32)} $ (@{const compress_parsed_extra (32)} $ t))
fun mk_MatchExpr t = if fastype_of t <> @{typ "32 common_primitive negation_type list"}
then
raise Fail "Type Error"
else
hacky_hack t;
fun mk_Rule_help t a = let val r = @{const Rule ("32 common_primitive")} $ (mk_MatchExpr t) $ a in
if fastype_of r <> @{typ "32 common_primitive rule"} then raise Fail "Type error in mk_Rule_help"
else r end;
fun append table chain rule = case FirewallTable.lookup table chain
of NONE => raise Fail ("uninitialized cahin: "^chain)
| SOME rules => FirewallTable.update (chain, rules@[rule]) table
fun mk_Rule (tbl: firewall_table) (chain: string, target : (parsed_action_type * string) option, t : term) =
if not (FirewallTable.defined tbl chain)
then
raise Fail ("undefined chain to be appended: "^chain)
else case target
of NONE => mk_Rule_help t @{const action.Empty}
| SOME (TypeCall, "ACCEPT") => mk_Rule_help t @{const action.Accept}
| SOME (TypeCall, "DROP") => mk_Rule_help t @{const action.Drop}
| SOME (TypeCall, "REJECT") => mk_Rule_help t @{const action.Reject}
| SOME (TypeCall, "LOG") => mk_Rule_help t @{const action.Log}
| SOME (TypeCall, "RETURN") => mk_Rule_help t @{const action.Return}
| SOME (TypeCall, custom) => if not (FirewallTable.defined tbl custom)
then
raise Fail ("unknown action: "^custom)
else
mk_Rule_help t (@{const action.Call} $ HOLogic.mk_string custom)
| SOME (TypeGoto, "ACCEPT") => raise Fail "Unexpected"
| SOME (TypeGoto, "DROP") => raise Fail "Unexpected"
| SOME (TypeGoto, "REJECT") => raise Fail "Unexpected"
| SOME (TypeGoto, "LOG") => raise Fail "Unexpected"
| SOME (TypeGoto, "RETURN") => raise Fail "Unexpected"
| SOME (TypeGoto, custom) => if not (FirewallTable.defined tbl custom)
then
raise Fail ("unknown action: "^custom)
else
mk_Rule_help t (@{const action.Goto} $ HOLogic.mk_string custom);
in
local
fun append_rule (tbl: firewall_table) (chain: string, target : (parsed_action_type * string) option, t : term) = append tbl chain (mk_Rule tbl (chain, target, t))
in
fun make_firewall_table (parsed_chain_decls : string list, parsed_rules : (string * (parsed_action_type * string) option * term) list) =
fold (fn rule => fn accu => append_rule accu rule) parsed_rules (FirewallTable_init parsed_chain_decls);
end
end
›
ML‹
fun mk_Ruleset (tbl: firewall_table) = FirewallTable.dest tbl
|> map (fn (k,v) => HOLogic.mk_prod (HOLogic.mk_string k, HOLogic.mk_list @{typ "32 common_primitive rule"} v))
|> HOLogic.mk_list @{typ "string × 32 common_primitive rule list"}
›
ML‹
local
fun default_policy_action_to_term "ACCEPT" = @{const "action.Accept"}
| default_policy_action_to_term "DROP" = @{const "action.Drop"}
| default_policy_action_to_term a = raise Fail ("Not a valid default policy `"^a^"'")
in
fun preparedefault_policies [] = []
| preparedefault_policies ((chain_name, SOME default_policy)::ls) =
(chain_name, default_policy_action_to_term default_policy) :: preparedefault_policies ls
| preparedefault_policies ((_, NONE)::ls) = preparedefault_policies ls
end
›
ML‹
fun trace_timing (printstr : string) (f : 'a -> 'b) (a : 'a) : 'b =
let val t0 = Time.now(); in
let val result = f a; in
let val t1= Time.now(); in
let val _ = writeln(String.concat [printstr^" (", Time.toString(Time.-(t1,t0)), " seconds)"]) in
result
end end end end;
fun simplify_code ctxt = let val _ = writeln "unfolding (this may take a while) ..." in
trace_timing "Simplified term" (Code_Evaluation.dynamic_value_strict ctxt)
end
fun certify_term ctxt t = trace_timing "Certified term" (Thm.cterm_of ctxt) t
›
ML_val‹
fun parse_iptables_save_global thy (file: string list) : term =
load_filter_table thy file
|> rule_type_partition
|> filter_chain_decls_names_only
|> make_firewall_table
|> mk_Ruleset
|> simplify_code @{context}
›
ML‹
local
fun define_const t name lthy = let
val binding_name = Thm.def_binding name
val _ = writeln ("Defining constant `" ^ Binding.name_of binding_name ^ "'");
in
lthy
|> Proof_Context.set_stmt false
|> Local_Theory.define ((name, NoSyn), ((binding_name, @{attributes [code]}), t)) |> #2
end;
fun print_default_policies (ps: (string * term) list) = let
val _ = ps |> map (fn (name, _) =>
if name <> "INPUT" andalso name <> "FORWARD" andalso name <> "OUTPUT"
then
writeln ("WARNING: the chain `"^name^"' is not a built-in chain of the filter table")
else ())
in ps end;
fun sanity_check_ruleset ctxt t = let
val check = Code_Evaluation.dynamic_value_strict ctxt (@{const sanity_wf_ruleset ("32 common_primitive")} $ t)
in
if check <> @{term "True"} then raise ERROR "sanity_wf_ruleset failed" else t
end;
in
fun parse_iptables_save table name path lthy =
let
val prepared = path
|> load_table table (Proof_Context.theory_of lthy)
|> rule_type_partition
val firewall = prepared
|> filter_chain_decls_names_only
|> make_firewall_table
|> mk_Ruleset
|> simplify_code lthy
|> trace_timing "checked sanity with sanity_wf_ruleset" (sanity_check_ruleset lthy)
val default_policis = prepared
|> get_chain_decls_policy
|> preparedefault_policies
|> print_default_policies
in
lthy
|> define_const firewall name
|> fold (fn (chain_name, policy) =>
define_const policy (Binding.name (Binding.name_of name ^ "_" ^ chain_name ^ "_default_policy")))
default_policis
end
end
›
ML‹
Outer_Syntax.local_theory @{command_keyword parse_iptables_save}
"load a file generated by iptables-save and make the firewall definition available as isabelle term"
(Parse.binding --| @{keyword "="} -- Scan.repeat1 Parse.path >>
(fn (binding, paths) => parse_iptables_save "filter" binding paths))
›
end
Theory Code_haskell
theory Code_haskell
imports
Routing.IpRoute_Parser
"Primitive_Matchers/Parser"
begin
definition word_less_eq :: "('a::len) word ⇒ ('a::len) word ⇒ bool" where
"word_less_eq a b ≡ a ≤ b"
definition word_to_nat :: "('a::len) word ⇒ nat" where
"word_to_nat = Word.unat"
definition mk_Set :: "'a list ⇒ 'a set" where
"mk_Set = set"
text‹Assumes that you call @{const fill_l4_protocol} after parsing!›
definition mk_L4Ports_pre :: "raw_ports ⇒ ipt_l4_ports" where
"mk_L4Ports_pre ports_raw = L4Ports 0 ports_raw"
fun ipassmt_iprange_translate :: "'i::len ipt_iprange list negation_type ⇒ ('i word × nat) list" where
"ipassmt_iprange_translate (Pos ips) = concat (map ipt_iprange_to_cidr ips)" |
"ipassmt_iprange_translate (Neg ips) = all_but_those_ips (concat (map ipt_iprange_to_cidr ips))"
definition to_ipassmt
:: "(iface × 'i::len ipt_iprange list negation_type) list ⇒ (iface × ('i word × nat) list) list" where
"to_ipassmt assmt = map (λ(ifce, ips). (ifce, ipassmt_iprange_translate ips)) assmt"
definition "zero_word ≡ 0 :: ('a :: len) word"
export_code Rule
Match MatchNot MatchAnd MatchAny
Src Dst IIface OIface Prot Src_Ports Dst_Ports CT_State Extra
mk_L4Ports_pre
ProtoAny Proto TCP UDP ICMP L4_Protocol.IPv6ICMP L4_Protocol.SCTP L4_Protocol.GRE
L4_Protocol.ESP L4_Protocol.AH
Iface
integer_to_16word nat_to_16word nat_of_integer integer_of_nat word_less_eq word_to_nat
nat_to_8word
IpAddrNetmask IpAddrRange IpAddr
CT_New CT_Established CT_Related CT_Untracked CT_Invalid
TCP_Flags TCP_SYN TCP_ACK TCP_FIN TCP_RST TCP_URG TCP_PSH
Accept Drop Log Reject Call Return Goto Empty Unknown
action_toString
ipv4addr_of_dotdecimal
ipt_ipv4range_toString
common_primitive_ipv4_toString
common_primitive_match_expr_ipv4_toString
simple_rule_ipv4_toString
mk_ipv6addr IPv6AddrPreferred ipv6preferred_to_int int_to_ipv6preferred
ipt_ipv6range_toString
common_primitive_ipv6_toString
common_primitive_match_expr_ipv6_toString
simple_rule_ipv6_toString
Semantics_Goto.rewrite_Goto_safe
alist_and' compress_parsed_extra fill_l4_protocol Pos Neg mk_Set
unfold_ruleset_CHAIN_safe map_of_string
upper_closure
abstract_for_simple_firewall optimize_matches
packet_assume_new
to_simple_firewall
to_simple_firewall_without_interfaces
sanity_wf_ruleset
has_default_policy
ipassmt_generic_ipv4 ipassmt_generic_ipv6
no_spoofing_iface ipassmt_sanity_defined map_of_ipassmt to_ipassmt ipassmt_diff
Pos Neg
simple_fw_valid
debug_ipassmt_ipv4 debug_ipassmt_ipv6
access_matrix_pretty_ipv4 access_matrix_pretty_ipv6
mk_parts_connection_TCP
PrefixMatch routing_rule_ext routing_action_ext
routing_action_oiface_update metric_update routing_action_next_hop_update empty_rr_hlp sort_rtbl
prefix_match_32_toString routing_rule_32_toString prefix_match_128_toString routing_rule_128_toString
default_prefix sanity_ip_route ipassmt_diff routing_ipassmt
checking SML Haskell?
end
Theory Access_Matrix_Embeddings
theory Access_Matrix_Embeddings
imports Semantics_Embeddings
"Primitive_Matchers/No_Spoof"
Simple_Firewall.Service_Matrix
begin
section‹Applying the Access Matrix to the Bigstep Semantics›
text‹
If the real iptables firewall (@{const iptables_bigstep}) accepts a packet, we have a corresponding
edge in the @{const access_matrix}.
›
corollary access_matrix_and_bigstep_semantics:
defines "preprocess rs ≡ upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new rs)))"
and "newpkt p ≡ match_tcp_flags ipt_tcp_syn (p_tcp_flags p) ∧ p_tag_ctstate p = CT_New"
fixes γ :: "'i::len common_primitive ⇒ ('i, 'pkt_ext) tagged_packet_scheme ⇒ bool"
and p :: "('i::len, 'pkt_ext) tagged_packet_scheme"
assumes agree:"matcher_agree_on_exact_matches γ common_matcher"
and simple: "simple_ruleset rs"
and new: "newpkt p"
and matrix: "(V,E) = access_matrix ⦇pc_iiface = p_iiface p, pc_oiface = p_oiface p, pc_proto = p_proto p, pc_sport = p_sport p, pc_dport = p_dport p⦈ (to_simple_firewall (preprocess rs))"
and accept: "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow"
shows "∃s_repr d_repr s_range d_range. (s_repr, d_repr) ∈ set E ∧
(map_of V) s_repr = Some s_range ∧ (p_src p) ∈ wordinterval_to_set s_range ∧
(map_of V) d_repr = Some d_range ∧ (p_dst p) ∈ wordinterval_to_set d_range"
proof -
let ?c="⦇ pc_iiface = p_iiface p, c_oiface = p_oiface p, pc_proto = p_proto p,
pc_sport = p_sport p, pc_dport = p_dport p ⦈"
from new_packets_to_simple_firewall_overapproximation[OF agree simple] have
"{p. Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow ∧ newpkt p}
⊆
{p. simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow ∧ newpkt p}"
unfolding preprocess_def newpkt_def by blast
with accept new have "simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow" by blast
hence "runFw_scheme (p_src p) (p_dst p) ?c p (to_simple_firewall (preprocess rs)) = Decision FinalAllow"
by(simp add: runFw_scheme_def)
hence "runFw (p_src p) (p_dst p) ?c (to_simple_firewall (preprocess rs)) = Decision FinalAllow"
by(simp add: runFw_scheme[symmetric])
with access_matrix[OF matrix] show ?thesis by presburger
qed
corollary access_matrix_no_interfaces_and_bigstep_semantics:
defines "newpkt p ≡ match_tcp_flags ipt_tcp_syn (p_tcp_flags p) ∧ p_tag_ctstate p = CT_New"
fixes γ :: "'i::len common_primitive ⇒ ('i, 'pkt_ext) tagged_packet_scheme ⇒ bool"
and p :: "('i::len, 'pkt_ext) tagged_packet_scheme"
assumes agree:"matcher_agree_on_exact_matches γ common_matcher"
and simple: "simple_ruleset rs"
and wf_ipassmt1: "ipassmt_sanity_nowildcards (map_of ipassmt)" and wf_ipassmt2: "distinct (map fst ipassmt)"
and nospoofing: "∀(p::('i::len, 'pkt_ext) tagged_packet_scheme).
∃ips. (map_of ipassmt) (Iface (p_iiface p)) = Some ips ∧ p_src p ∈ ipcidr_union_set (set ips)"
and routing_decided: "⋀rtbl (p::('i,'pkt_ext) tagged_packet_scheme). rtblo = Some rtbl ⟹ output_iface (routing_table_semantics rtbl (p_dst p)) = p_oiface p"
and correct_routing: "⋀rtbl. rtblo = Some rtbl ⟹ correct_routing rtbl"
and routing_no_wildcards: "⋀rtbl. rtblo = Some rtbl ⟹ ipassmt_sanity_nowildcards (map_of (routing_ipassmt rtbl))"
and new: "newpkt p"
and matrix: "(V,E) = access_matrix ⦇pc_iiface = anyI, pc_oiface = anyO, pc_proto = p_proto p, pc_sport = p_sport p, pc_dport = p_dport p⦈
(to_simple_firewall_without_interfaces ipassmt rtblo rs)"
and accept: "Γ,γ,p⊢ ⟨rs, Undecided⟩ ⇒ Decision FinalAllow"
shows "∃s_repr d_repr s_range d_range. (s_repr, d_repr) ∈ set E ∧
(map_of V) s_repr = Some s_range ∧ (p_src p) ∈ wordinterval_to_set s_range ∧
(map_of V) d_repr = Some d_range ∧ (p_dst p) ∈ wordinterval_to_set d_range"
proof -
let ?c="⦇ pc_iiface = p_iiface p, c_oiface = p_oiface p, pc_proto = p_proto p,
pc_sport = p_sport p, pc_dport = p_dport p ⦈"
let ?srs="to_simple_firewall_without_interfaces ipassmt rtblo rs"
note tosfw=to_simple_firewall_without_interfaces[OF simple wf_ipassmt1 wf_ipassmt2 nospoofing routing_decided correct_routing routing_no_wildcards, of rtblo, simplified]
from tosfw(2) have no_ifaces: "simple_firewall_without_interfaces ?srs" unfolding simple_firewall_without_interfaces_def by fastforce
from simple simple_imp_good_ruleset have "good_ruleset rs" by blast
with accept FinalAllow_approximating_in_doubt_allow[OF agree] have accept_ternary:
"(common_matcher, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow" by blast
from tosfw(1) have
"{p.(common_matcher, in_doubt_allow),p⊢ ⟨rs, Undecided⟩ ⇒⇩α Decision FinalAllow ∧ newpkt p}
⊆
{p. simple_fw ?srs p = Decision FinalAllow ∧ newpkt p}"
unfolding newpkt_def by blast
with accept_ternary new have "simple_fw ?srs p = Decision FinalAllow" by blast
hence "runFw_scheme (p_src p) (p_dst p) ?c p ?srs = Decision FinalAllow"
by(simp add: runFw_scheme_def)
hence "runFw (p_src p) (p_dst p) ?c ?srs = Decision FinalAllow"
by(simp add: runFw_scheme[symmetric])
hence "runFw (p_src p) (p_dst p)
⦇pc_iiface = anyI, pc_oiface = anyO, pc_proto = p_proto p, pc_sport = p_sport p, pc_dport = p_dport p⦈ ?srs = Decision FinalAllow"
apply(subst runFw_no_interfaces[OF no_ifaces]) by simp
with access_matrix[OF matrix] show ?thesis by presburger
qed
end
Theory Documentation
theory Documentation
imports Semantics_Embeddings
Call_Return_Unfolding
No_Spoof_Embeddings
Access_Matrix_Embeddings
"Primitive_Matchers/Code_Interface"
begin
section‹Documentation›
subsection‹General Model›
text‹
The semantics of the filtering behavior of iptables is expressed by @{const iptables_bigstep}.
The notation @{term "Γ,γ,p⊢ ⟨rs, s⟩ ⇒ t"} reads as follows:
@{term "Γ :: string ⇀ 'a rule list"} is the background ruleset (user-defined rules).
@{term γ} is a function @{typ "('a, 'p) matcher"} which is called the primitive matcher (i.e. the matching features supported by iptables).
@{term "p :: 'p"} is the packet inspected by the firewall.
@{term "rs :: 'a rule list"} is the ruleset.
@{term "s :: state"} and @{term "t :: state"} are the start state and final state.
The semantics:
\begin{center}
@{thm[mode=Axiom] skip [no_vars]}\\[1ex]
@{thm[mode=Rule] accept [no_vars]}\\[1ex]
@{thm[mode=Rule] drop [no_vars]}\\[1ex]
@{thm[mode=Rule] reject [no_vars]}\\[1ex]
@{thm[mode=Rule] log [no_vars]}\\[1ex]
@{thm[mode=Rule] empty [no_vars]}\\[1ex]
@{thm[mode=Rule] nomatch [no_vars]}\\[1ex]
@{thm[mode=Rule] decision [no_vars]}\\[1ex]
@{thm[mode=Rule] seq [no_vars]} \\[1ex]
@{thm[mode=Rule] call_return [no_vars]}\\[1ex]
@{thm[mode=Rule] call_result [no_vars]}
\end{center}
›
subsection‹Unfolding the Ruleset›
text‹We can replace all @{const Goto}s to terminal chains (chains that ultimately yield a final
decision for every packet) with @{const Call}s.
Otherwise we don't have as rich goto semantics as iptables has, but this rewriting is safe.
@{thm Semantics_Goto.rewrite_Goto_chain_safe [no_vars]}
›
text‹The iptables firewall starts as follows:
@{term "[Rule MatchAny (Call chain_name), Rule MatchAny default_action]"}
We call to a built-in chain @{term chain_name}, usually INPUT, OUTPUT, or FORWARD.
If we don't get a decision, iptables uses the default policy (-P) @{term default_action}.
We can call @{const unfold_optimize_ruleset_CHAIN} to remove all calls to user-defined chains
and other unpleasant actions. We get back a @{const simple_ruleset} which as exactly the same
behaviour. As a bonus, this @{const simple_ruleset} already has some match conditions optimized.
For example, if the parser does not find a source IP in a rule, it is okay to specify
-s 0.0.0.0/0, the unfolding will optimize away these things for you.
Or if you parse iptables -L -n which always has these annoying 0.0.0.0/0 fields.
May make the parser easier.
The following lemma shows that this does not change the semantics.
›
lemma unfold_optimize_common_matcher_univ_ruleset_CHAIN:
fixes γ :: "'i::len common_primitive ⇒ ('i, 'pkt_ext) tagged_packet_scheme ⇒ bool"
and p :: "('i::len, 'pkt_ext) tagged_packet_scheme"
assumes "sanity_wf_ruleset Γ" and "chain_name ∈ set (map fst Γ)"
and "default_action = action.Accept ∨ default_action = action.Drop"
and "matcher_agree_on_exact_matches γ common_matcher"
and "unfold_ruleset_CHAIN_safe chain_name default_action (map_of Γ) = Some rs"
shows "(map_of Γ),γ,p⊢ ⟨rs, s⟩ ⇒ t ⟷
(map_of Γ),γ,p⊢ ⟨[Rule MatchAny (Call chain_name), Rule MatchAny default_action], s⟩ ⇒ t"
and "simple_ruleset rs"
apply(intro unfold_optimize_ruleset_CHAIN[where optimize=optimize_primitive_univ, OF assms(1) assms(2) assms(3)])
using assms apply(simp_all add: unfold_ruleset_CHAIN_safe_def Semantics_optimize_primitive_univ_common_matcher)
by(simp add: unfold_optimize_ruleset_CHAIN_def Let_def split: if_split_asm)
subsection‹Spoofing protection›
text‹We provide an executable algorithm @{const no_spoofing_iface} which checks that a ruleset provides spoofing protection:
@{thm no_spoofing_executable_set [no_vars]}
Text the firewall needs normalized match conditions, this is a good way to preprocess the firewall before
checking spoofing protection:
@{thm no_spoofing_executable_set_preprocessed [no_vars]}
›
subsection‹Simple Firewall Model›
text‹The simple firewall supports the following match conditions: @{typ "'i::len simple_match"}.
The @{const simple_fw} model is remarkably simple: @{thm simple_fw.simps [no_vars]}
We support translating to a stricter version (a version that accepts less packets):
@{thm new_packets_to_simple_firewall_underapproximation [no_vars]}
We support translating to a more permissive version (a version that accepts more packets):
@{thm new_packets_to_simple_firewall_overapproximation [no_vars]}
There is also a different approach to translate to the simple firewall which removes all matches on interfaces:
@{thm to_simple_firewall_without_interfaces[no_vars]}
›
subsection‹Service Matrices›
text‹
For a @{typ "'i::len simple_rule list"} and a fixed @{typ parts_connection},
we support to partition the IPv4 address space the following.
All members of a partition have the same access rights:
@{thm build_ip_partition_same_fw [no_vars]}
Minimal:
@{thm build_ip_partition_same_fw_min [no_vars]}
The resulting access control matrix is sound and complete:
@{thm access_matrix [no_vars]}
Theorem reads:
For a fixed connection, you can look up IP addresses (source and destination pairs) in the matrix
if and only if the firewall accepts this src,dst IP address pair for the fixed connection.
Note: The matrix is actually a graph (nice visualization!), you need to look up IP addresses
in the Vertices and check the access of the representants in the edges. If you want to visualize
the graph (e.g. with Graphviz or tkiz): The vertices are the node description (i.e. header;
@{term "dom V"} is the label for each node which will also be referenced in the edges,
@{term "ran V"} is the human-readable description for each node (i.e. the full IP range it represents)),
the edges are the edges. Result looks nice. Theorem also tells us that this visualization is correct.
›
text‹
A final theorem which does not mention the simple firewall at all.
If the real iptables firewall (@{const iptables_bigstep}) accepts a packet, we have a corresponding
edge in the @{const access_matrix}:
@{thm access_matrix_and_bigstep_semantics [no_vars]}
Actually, we want to ignore all interfaces for a service matrix.
This is done in @{thm access_matrix_no_interfaces_and_bigstep_semantics[no_vars]}.
The theorem reads a bit ugly because we need well-formedness assumptions if we rewrite interfaces.
Internally, it uses @{const iface_try_rewrite} which is pretty safe to use, even if you don't have
an @{term ipassmt} or routing tables.
›
end